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

More refactoring

Browse Source 
- Add `properties` to view properties of widgets.
- Remove use of `Numeric.Natural`.
- Add verification mechanisms to `Attr`.
This commit is contained in:
Sumit Sahrawat 2015-07-13 06:28:30 +05:30
parent 26addb62a3
commit 3466245bf8
20 changed files with 242 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,14 +2,15 @@
> Largely based on: https://github.com/ipython/ipython/wiki/IPEP-23:-Backbone.js-Widgets
> The messaging specification as detailed is riddled with the assumptions IHaskell's widget
> The messaging specification as detailed is riddled with assumptions IHaskell's widget
> implementation makes. It works for us, so it should work for everyone.
## Creating widgets
Let's say the user types in some code, and the only effect of that code is the creation of a widget.
The kernel will open a comm for the widget, and store a reference to that comm inside it. Then, to
notify the frontend about the creation of a widget, an initial state update is sent on the widget's comm.
notify the frontend about the creation of a widget, an initial state update is sent on the widget's
comm.
> The comm should be opened with a `target_name` of `"ipython.widget"`.
@ -22,7 +23,9 @@ The initial state update message looks like this:
}
```
Any *numeric* 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. Some numbers need to be sent as actual numbers (when non-null), whereas some (especially
those used by sliders) need to be sent as strings.
The initial state update must *at least* have the following fields:

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

@ -33,4 +33,4 @@ 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)
import IHaskell.Display.Widgets.Types as X (setField, getField, properties)

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

@ -12,7 +12,7 @@ CheckBox,
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when, join)
import Control.Monad (when, join, void)
import Data.Aeson
import Data.HashMap.Strict as HM
import Data.IORef (newIORef)
@ -61,4 +61,4 @@ instance IHaskellWidget CheckBox where
key2 = "value" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (Bool value) = HM.lookup key2 dict2
setField' widget SBoolValue value
void $ setField' widget SBoolValue value

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

@ -5,14 +5,14 @@
module IHaskell.Display.Widgets.Bool.ToggleButton (
-- * The ToggleButton Widget
ToggleButton,
ToggleButton,
-- * Constructor
mkToggleButton) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when, join)
import Control.Monad (when, join, void)
import Data.Aeson
import Data.HashMap.Strict as HM
import Data.IORef (newIORef)
@ -66,4 +66,4 @@ instance IHaskellWidget ToggleButton where
key2 = "value" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (Bool value) = HM.lookup key2 dict2
setField' widget SBoolValue value
void $ setField' widget SBoolValue value

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

@ -6,6 +6,7 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module IHaskell.Display.Widgets.Common where
import Data.Aeson
@ -81,6 +82,11 @@ singletons [d|
deriving (Eq, Ord, Show)
|]
newtype StrInt = StrInt Integer deriving (Num, Ord, Eq, Enum)
instance ToJSON StrInt where
toJSON (StrInt x) = toJSON . pack $ show x
-- | Pre-defined border styles
data BorderStyleValue = NoBorder
| HiddenBorder

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Float/BoundedFloat/BoundedFloatText.hs
View File

@ -13,7 +13,7 @@ module IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText (
import Prelude
import Control.Exception (throw, ArithException (LossOfPrecision))
import Control.Monad (when, join)
import Control.Monad (when, join, void)
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef (newIORef)
@ -68,4 +68,4 @@ instance IHaskellWidget BoundedFloatText where
newValue <- if abs value < 10 ^ 16
then return (Sci.toRealFloat value)
else throw LossOfPrecision
setField' widget SFloatValue newValue
void $ setField' widget SFloatValue newValue

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatSlider.hs
View File

@ -13,7 +13,7 @@ module IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider (
import Prelude
import Control.Exception (throw, ArithException (LossOfPrecision))
import Control.Monad (when, join)
import Control.Monad (when, join, void)
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef (newIORef)
@ -74,4 +74,4 @@ instance IHaskellWidget FloatSlider where
newValue <- if abs value < 10 ^ 16
then return (Sci.toRealFloat value)
else throw LossOfPrecision
setField' widget SFloatValue newValue
void $ setField' widget SFloatValue newValue

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Float/BoundedFloatRange/FloatRangeSlider.hs
View File

@ -13,7 +13,7 @@ module IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider (
import Prelude
import Control.Exception (throw, ArithException (LossOfPrecision))
import Control.Monad (when, join)
import Control.Monad (when, join, void)
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef (newIORef)
@ -73,4 +73,4 @@ instance IHaskellWidget FloatRangeSlider where
Just (Object dict2) = HM.lookup key1 dict1
Just (Array values) = HM.lookup key2 dict2
[x, y] = map (\(Number x) -> Sci.toRealFloat x) $ V.toList values
setField' widget SFloatPairValue (x, y)
void $ setField' widget SFloatPairValue (x, y)

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Float/FloatText.hs
View File

@ -13,7 +13,7 @@ module IHaskell.Display.Widgets.Float.FloatText (
import Prelude
import Control.Exception (throw, ArithException (LossOfPrecision))
import Control.Monad (when, join)
import Control.Monad (when, join, void)
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef (newIORef)
@ -65,4 +65,4 @@ instance IHaskellWidget FloatText where
newValue <- if abs value < 10 ^ 16
then return (Sci.toRealFloat value)
else throw LossOfPrecision
setField' widget SFloatValue newValue
void $ setField' widget SFloatValue newValue

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Int/BoundedInt/BoundedIntText.hs
View File

@ -13,7 +13,7 @@ module IHaskell.Display.Widgets.Int.BoundedInt.BoundedIntText (
import Prelude
import Control.Exception (throw, ArithException (LossOfPrecision))
import Control.Monad (when, join)
import Control.Monad (when, join, void)
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef (newIORef)
@ -68,4 +68,4 @@ instance IHaskellWidget BoundedIntText where
newValue <- if abs value < 10 ^ 16
then return (Sci.coefficient value)
else throw LossOfPrecision
setField' widget SIntValue newValue
void $ setField' widget SIntValue newValue

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Int/BoundedInt/IntSlider.hs
View File

@ -13,7 +13,7 @@ module IHaskell.Display.Widgets.Int.BoundedInt.IntSlider (
import Prelude
import Control.Exception (throw, ArithException (LossOfPrecision))
import Control.Monad (when, join)
import Control.Monad (when, join, void)
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef (newIORef)
@ -74,4 +74,4 @@ instance IHaskellWidget IntSlider where
newValue <- if abs value < 10 ^ 16
then return (Sci.coefficient value)
else throw LossOfPrecision
setField' widget SIntValue newValue
void $ setField' widget SIntValue newValue

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Int/BoundedIntRange/IntRangeSlider.hs
View File

@ -13,7 +13,7 @@ module IHaskell.Display.Widgets.Int.BoundedIntRange.IntRangeSlider (
import Prelude
import Control.Exception (throw, ArithException (LossOfPrecision))
import Control.Monad (when, join)
import Control.Monad (when, join, void)
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef (newIORef)
@ -73,4 +73,4 @@ instance IHaskellWidget IntRangeSlider where
Just (Object dict2) = HM.lookup key1 dict1
Just (Array values) = HM.lookup key2 dict2
[x, y] = map (\(Number x) -> Sci.coefficient x) $ V.toList values
setField' widget SIntPairValue (x, y)
void $ setField' widget SIntPairValue (x, y)

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Int/IntText.hs
View File

@ -13,7 +13,7 @@ module IHaskell.Display.Widgets.Int.IntText (
import Prelude
import Control.Exception (throw, ArithException (LossOfPrecision))
import Control.Monad (when, join)
import Control.Monad (when, join, void)
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef (newIORef)
@ -65,4 +65,4 @@ instance IHaskellWidget IntText where
newValue <- if abs value < 10 ^ 16
then return (Sci.coefficient value)
else throw LossOfPrecision
setField' widget SIntValue newValue
void $ setField' widget SIntValue newValue

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

@ -5,14 +5,14 @@
module IHaskell.Display.Widgets.Selection.Dropdown (
-- * The Dropdown Widget
Dropdown,
Dropdown,
-- * Constructor
mkDropdown) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when, join)
import Control.Monad (when, join, void)
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef (newIORef)
@ -68,13 +68,13 @@ instance IHaskellWidget Dropdown where
Just (String label) = HM.lookup key2 dict2
opts <- getField widget SOptions
case opts of
OptionLabels _ -> do
OptionLabels _ -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue label
OptionDict ps ->
case lookup label ps of
Nothing -> return ()
Just value -> do
Just value -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue value
triggerSelection widget

8
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/RadioButtons.hs
View File

@ -5,14 +5,14 @@
module IHaskell.Display.Widgets.Selection.RadioButtons (
-- * The RadioButtons Widget
RadioButtons,
RadioButtons,
-- * Constructor
mkRadioButtons) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when, join)
import Control.Monad (when, join, void)
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef (newIORef)
@ -66,13 +66,13 @@ instance IHaskellWidget RadioButtons where
Just (String label) = HM.lookup key2 dict2
opts <- getField widget SOptions
case opts of
OptionLabels _ -> do
OptionLabels _ -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue label
OptionDict ps ->
case lookup label ps of
Nothing -> return ()
Just value -> do
Just value -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue value
triggerSelection widget

6
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/Select.hs
View File

@ -12,7 +12,7 @@ Select,
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when, join)
import Control.Monad (when, join, void)
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef (newIORef)
@ -65,13 +65,13 @@ instance IHaskellWidget Select where
Just (String label) = HM.lookup key2 dict2
opts <- getField widget SOptions
case opts of
OptionLabels _ -> do
OptionLabels _ -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue label
OptionDict ps ->
case lookup label ps of
Nothing -> return ()
Just value -> do
Just value -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue value
triggerSelection widget

6
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/SelectMultiple.hs
View File

@ -12,7 +12,7 @@ SelectMultiple,
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (fmap, join, sequence)
import Control.Monad (fmap, join, sequence, void)
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef (newIORef)
@ -70,13 +70,13 @@ instance IHaskellWidget SelectMultiple where
labelList = map (\(String x) -> x) $ V.toList labels
opts <- getField widget SOptions
case opts of
OptionLabels _ -> do
OptionLabels _ -> void $ do
setField' widget SSelectedLabels labelList
setField' widget SSelectedValues labelList
OptionDict ps ->
case sequence $ map (`lookup` ps) labelList of
Nothing -> return ()
Just valueList -> do
Just valueList -> void $ do
setField' widget SSelectedLabels labelList
setField' widget SSelectedValues valueList
triggerSelection widget

8
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/ToggleButtons.hs
View File

@ -5,14 +5,14 @@
module IHaskell.Display.Widgets.Selection.ToggleButtons (
-- * The ToggleButtons Widget
ToggleButtons,
ToggleButtons,
-- * Constructor
mkToggleButtons) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when, join)
import Control.Monad (when, join, void)
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef (newIORef)
@ -73,13 +73,13 @@ instance IHaskellWidget ToggleButtons where
Just (String label) = HM.lookup key2 dict2
opts <- getField widget SOptions
case opts of
OptionLabels _ -> do
OptionLabels _ -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue label
OptionDict ps ->
case lookup label ps of
Nothing -> return ()
Just value -> do
Just value -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue value
triggerSelection widget

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

@ -5,9 +5,9 @@
module IHaskell.Display.Widgets.String.Text (
-- * The Text Widget
TextWidget,
TextWidget,
-- * Constructor
mkTextWidget,
mkTextWidget,
-- * Submit handling
triggerSubmit) where
@ -66,7 +66,7 @@ instance IHaskellWidget TextWidget where
case Map.lookup "sync_data" dict1 of
Just (Object dict2) ->
case Map.lookup "value" dict2 of
Just (String val) -> setField' tw SStringValue val
Just (String val) -> setField' tw SStringValue val >> return ()
Nothing -> return ()
Nothing ->
case Map.lookup "content" dict1 of

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

@ -36,14 +36,21 @@ module IHaskell.Display.Widgets.Types where
-- is a type present in the type-level list @ts@. Thus a 'WidgetState' is essentially a list of field
-- properties wrapped together with the corresponding promoted Field type. See ('=::') for more.
--
-- The properties function can be used to view all the @Field@s associated with a widget object.
--
-- Attributes are represented by the @Attr@ data type, which holds the value of a field, along with
-- the actual @Field@ object and a function to verify validity of changes to the value.
--
-- The IPython widgets expect state updates of the form {"property": value}, where an empty string for
-- numeric values 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. Some numbers need to
-- be sent as numbers (represented by @Integer@), whereas some need to be sent as Strings (@StrInt@).
--
-- To know more about the IPython messaging specification (as implemented in this package) take a look
-- at the supplied MsgSpec.md.
import Control.Monad (when)
import Control.Monad (unless)
import Control.Applicative ((<$>))
import qualified Control.Exception as Ex
import Data.Aeson
import Data.Aeson.Types (emptyObject, Pair)
@ -58,8 +65,6 @@ import Data.Vinyl.TypeLevel (RecAll (..))
import Data.Singletons.Prelude ((:++))
import Data.Singletons.TH
import Numeric.Natural
import IHaskell.Eval.Widgets (widgetSendUpdate)
import IHaskell.Display (Base64, IHaskellWidget (..))
import IHaskell.IPython.Message.UUID
@ -94,25 +99,25 @@ type family FieldType (f :: Field) :: * where
FieldType ModelName = Text
FieldType ViewModule = Text
FieldType ViewName = Text
FieldType MsgThrottle = Natural
FieldType Version = Natural
FieldType MsgThrottle = StrInt
FieldType Version = StrInt
FieldType OnDisplayed = IO ()
FieldType Visible = Bool
FieldType CSS = [(Text, Text, Text)]
FieldType DOMClasses = [Text]
FieldType Width = Natural
FieldType Height = Natural
FieldType Padding = Natural
FieldType Margin = Natural
FieldType Width = StrInt
FieldType Height = StrInt
FieldType Padding = StrInt
FieldType Margin = StrInt
FieldType Color = Text
FieldType BackgroundColor = Text
FieldType BorderColor = Text
FieldType BorderWidth = Natural
FieldType BorderRadius = Natural
FieldType BorderWidth = StrInt
FieldType BorderRadius = StrInt
FieldType BorderStyle = BorderStyleValue
FieldType FontStyle = FontStyleValue
FieldType FontWeight = FontWeightValue
FieldType FontSize = Natural
FieldType FontSize = StrInt
FieldType FontFamily = Text
FieldType Description = Text
FieldType ClickHandler = IO ()
@ -135,11 +140,11 @@ type family FieldType (f :: Field) :: * where
FieldType SelectedLabels = [Text]
FieldType SelectedValues = [Text]
FieldType IntValue = Integer
FieldType StepInt = Natural
FieldType MinInt = Int
FieldType MaxInt = Int
FieldType LowerInt = Int
FieldType UpperInt = Int
FieldType StepInt = Integer
FieldType MinInt = Integer
FieldType MaxInt = Integer
FieldType LowerInt = Integer
FieldType UpperInt = Integer
FieldType IntPairValue = (Integer, Integer)
FieldType Orientation = OrientationValue
FieldType ShowRange = Bool
@ -154,6 +159,25 @@ type family FieldType (f :: Field) :: * where
FieldType UpperFloat = Double
FieldType FloatPairValue = (Double, Double)
-- Will use a custom class rather than a newtype wrapper with an orphan instance. The main issue is
-- the need of a Bounded instance for Float / Double.
class CustomBounded a where
lowerBound :: a
upperBound :: a
-- Set according to what IPython widgets use
instance CustomBounded StrInt where
upperBound = 10 ^ 16 - 1
lowerBound = - (10 ^ 16 - 1)
instance CustomBounded Integer where
lowerBound = - (10 ^ 16 - 1)
upperBound = 10 ^ 16 - 1
instance CustomBounded Double where
lowerBound = - (10 ** 16 - 1)
upperBound = 10 ** 16 - 1
-- Different types of widgets. Every widget in IPython has a corresponding WidgetType
data WidgetType = ButtonType
| ImageType
@ -207,85 +231,127 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
WidgetFields FloatProgressType = BoundedFloatClass :++ '[BarStyle]
WidgetFields FloatRangeSliderType = BoundedFloatRangeClass :++ '[Orientation, ShowRange, ReadOut, SliderColor]
-- Wrapper around a field
newtype Attr (f :: Field) = Attr { _unAttr :: FieldType f }
-- Wrapper around a field's value. A dummy value is sent as an empty string to the frontend.
data AttrVal a = Dummy a | Real a
unwrap :: AttrVal a -> a
unwrap (Dummy x) = x
unwrap (Real x) = x
-- Wrapper around a field.
data Attr (f :: Field) =
Attr { _value :: AttrVal (FieldType f)
, _verify :: FieldType f -> IO (FieldType f)
, _field :: Field
}
instance ToJSON (FieldType f) => ToJSON (Attr f) where
toJSON attr = case _value attr of
Dummy _ -> ""
Real x -> toJSON x
-- Types that can be converted to Aeson Pairs.
class ToPairs a where
toPairs :: a -> [Pair]
-- Attributes that aren't synced with the frontend give [] on toPairs
instance ToPairs (Attr ModelModule) where toPairs (Attr x) = ["_model_module" .= toJSON x]
instance ToPairs (Attr ModelName) where toPairs (Attr x) = ["_model_name" .= toJSON x]
instance ToPairs (Attr ViewModule) where toPairs (Attr x) = ["_view_module" .= toJSON x]
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 ModelModule) where toPairs x = ["_model_module" .= toJSON x]
instance ToPairs (Attr ModelName) where toPairs x = ["_model_name" .= toJSON x]
instance ToPairs (Attr ViewModule) where toPairs x = ["_view_module" .= toJSON x]
instance ToPairs (Attr ViewName) where toPairs x = ["_view_name" .= toJSON x]
instance ToPairs (Attr MsgThrottle) where toPairs x = ["msg_throttle" .= toJSON x]
instance ToPairs (Attr Version) where toPairs x = ["version" .= toJSON x]
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]
instance ToPairs (Attr Width) where toPairs (Attr x) = ["width" .= toJSON x]
instance ToPairs (Attr Height) where toPairs (Attr x) = ["height" .= toJSON x]
instance ToPairs (Attr Padding) where toPairs (Attr x) = ["padding" .= toJSON x]
instance ToPairs (Attr Margin) where toPairs (Attr x) = ["margin" .= toJSON x]
instance ToPairs (Attr Color) where toPairs (Attr x) = ["color" .= toJSON x]
instance ToPairs (Attr BackgroundColor) where toPairs (Attr x) = ["background_color" .= toJSON x]
instance ToPairs (Attr BorderColor) where toPairs (Attr x) = ["border_color" .= toJSON x]
instance ToPairs (Attr BorderWidth) where toPairs (Attr x) = ["border_width" .= toJSON x]
instance ToPairs (Attr BorderRadius) where toPairs (Attr x) = ["border_radius" .= toJSON x]
instance ToPairs (Attr BorderStyle) where toPairs (Attr x) = ["border_style" .= toJSON x]
instance ToPairs (Attr FontStyle) where toPairs (Attr x) = ["font_style" .= toJSON x]
instance ToPairs (Attr FontWeight) where toPairs (Attr x) = ["font_weight" .= toJSON x]
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 Visible) where toPairs x = ["visible" .= toJSON x]
instance ToPairs (Attr CSS) where toPairs x = ["_css" .= toJSON x]
instance ToPairs (Attr DOMClasses) where toPairs x = ["_dom_classes" .= toJSON x]
instance ToPairs (Attr Width) where toPairs x = ["width" .= toJSON x]
instance ToPairs (Attr Height) where toPairs x = ["height" .= toJSON x]
instance ToPairs (Attr Padding) where toPairs x = ["padding" .= toJSON x]
instance ToPairs (Attr Margin) where toPairs x = ["margin" .= toJSON x]
instance ToPairs (Attr Color) where toPairs x = ["color" .= toJSON x]
instance ToPairs (Attr BackgroundColor) where toPairs x = ["background_color" .= toJSON x]
instance ToPairs (Attr BorderColor) where toPairs x = ["border_color" .= toJSON x]
instance ToPairs (Attr BorderWidth) where toPairs x = ["border_width" .= toJSON x]
instance ToPairs (Attr BorderRadius) where toPairs x = ["border_radius" .= toJSON x]
instance ToPairs (Attr BorderStyle) where toPairs x = ["border_style" .= toJSON x]
instance ToPairs (Attr FontStyle) where toPairs x = ["font_style" .= toJSON x]
instance ToPairs (Attr FontWeight) where toPairs x = ["font_weight" .= toJSON x]
instance ToPairs (Attr FontSize) where toPairs x = ["font_size" .= toJSON x]
instance ToPairs (Attr FontFamily) where toPairs x = ["font_family" .= toJSON x]
instance ToPairs (Attr Description) where toPairs x = ["description" .= toJSON x]
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]
instance ToPairs (Attr Tooltip) where toPairs (Attr x) = ["tooltip" .= toJSON x]
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]
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 Disabled) where toPairs x = ["disabled" .= toJSON x]
instance ToPairs (Attr StringValue) where toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr Placeholder) where toPairs x = ["placeholder" .= toJSON x]
instance ToPairs (Attr Tooltip) where toPairs x = ["tooltip" .= toJSON x]
instance ToPairs (Attr Icon) where toPairs x = ["icon" .= toJSON x]
instance ToPairs (Attr ButtonStyle) where toPairs x = ["button_style" .= toJSON x]
instance ToPairs (Attr B64Value) where toPairs x = ["_b64value" .= toJSON x]
instance ToPairs (Attr ImageFormat) where toPairs x = ["format" .= toJSON x]
instance ToPairs (Attr BoolValue) where toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr SelectedLabel) where toPairs x = ["selected_label" .= toJSON x]
instance ToPairs (Attr SelectedValue) where toPairs 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
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 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]
instance ToPairs (Attr IntValue) where toPairs (Attr x) = ["value" .= toJSON x]
instance ToPairs (Attr StepInt) where toPairs (Attr x) = ["step" .= toJSON x]
instance ToPairs (Attr MinInt) where toPairs (Attr x) = ["min" .= toJSON x]
instance ToPairs (Attr MaxInt) where toPairs (Attr x) = ["max" .= toJSON x]
instance ToPairs (Attr IntPairValue) where toPairs (Attr x) = ["value" .= toJSON x]
instance ToPairs (Attr LowerInt) where toPairs (Attr x) = ["min" .= toJSON x]
instance ToPairs (Attr UpperInt) where toPairs (Attr x) = ["max" .= toJSON x]
instance ToPairs (Attr FloatValue) where toPairs (Attr x) = ["value" .= toJSON x]
instance ToPairs (Attr StepFloat) where toPairs (Attr x) = ["step" .= toJSON x]
instance ToPairs (Attr MinFloat) where toPairs (Attr x) = ["min" .= toJSON x]
instance ToPairs (Attr MaxFloat) where toPairs (Attr x) = ["max" .= toJSON x]
instance ToPairs (Attr FloatPairValue) where toPairs (Attr x) = ["value" .= toJSON x]
instance ToPairs (Attr LowerFloat) where toPairs (Attr x) = ["min" .= toJSON x]
instance ToPairs (Attr UpperFloat) where toPairs (Attr x) = ["max" .= toJSON x]
instance ToPairs (Attr Orientation) where toPairs (Attr x) = ["orientation" .= toJSON x]
instance ToPairs (Attr ShowRange) where toPairs (Attr x) = ["_range" .= toJSON x]
instance ToPairs (Attr ReadOut) where toPairs (Attr x) = ["readout" .= toJSON x]
instance ToPairs (Attr SliderColor) where toPairs (Attr x) = ["slider_color" .= toJSON x]
instance ToPairs (Attr BarStyle) where toPairs (Attr x) = ["bar_style" .= toJSON x]
instance ToPairs (Attr Tooltips) where toPairs x = ["tooltips" .= toJSON x]
instance ToPairs (Attr Icons) where toPairs x = ["icons" .= toJSON x]
instance ToPairs (Attr SelectedLabels) where toPairs x = ["selected_labels" .= toJSON x]
instance ToPairs (Attr SelectedValues) where toPairs x = ["values" .= toJSON x]
instance ToPairs (Attr IntValue) where toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr StepInt) where toPairs x = ["step" .= toJSON x]
instance ToPairs (Attr MinInt) where toPairs x = ["min" .= toJSON x]
instance ToPairs (Attr MaxInt) where toPairs x = ["max" .= toJSON x]
instance ToPairs (Attr IntPairValue) where toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr LowerInt) where toPairs x = ["min" .= toJSON x]
instance ToPairs (Attr UpperInt) where toPairs x = ["max" .= toJSON x]
instance ToPairs (Attr FloatValue) where toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr StepFloat) where toPairs x = ["step" .= toJSON x]
instance ToPairs (Attr MinFloat) where toPairs x = ["min" .= toJSON x]
instance ToPairs (Attr MaxFloat) where toPairs x = ["max" .= toJSON x]
instance ToPairs (Attr FloatPairValue) where toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr LowerFloat) where toPairs x = ["min" .= toJSON x]
instance ToPairs (Attr UpperFloat) where toPairs x = ["max" .= toJSON x]
instance ToPairs (Attr Orientation) where toPairs x = ["orientation" .= toJSON x]
instance ToPairs (Attr ShowRange) where toPairs x = ["_range" .= toJSON x]
instance ToPairs (Attr ReadOut) where toPairs x = ["readout" .= toJSON x]
instance ToPairs (Attr SliderColor) where toPairs x = ["slider_color" .= toJSON x]
instance ToPairs (Attr BarStyle) where toPairs x = ["bar_style" .= toJSON x]
-- | Store the value for a field, as an object parametrized by the Field
(=::) :: sing f -> FieldType f -> Attr f
_ =:: x = Attr 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
s =:: x = Attr { _value = Real x, _verify = return, _field = reflect s }
-- | If the number is in the range, return it. Otherwise raise the appropriate (over/under)flow
-- exception.
rangeCheck :: (Num a, Ord a) => (a, a) -> a -> IO a
rangeCheck (l, u) x
| l <= x && x <= u = return x
| l > x = Ex.throw Ex.Underflow
| u < x = Ex.throw Ex.Overflow
-- | Store a numeric value, with verification mechanism for its range.
ranged :: (SingI f, Num (FieldType f), Ord (FieldType f))
=> Sing f -> (FieldType f, FieldType f) -> AttrVal (FieldType f) -> Attr f
ranged s range x = Attr x (rangeCheck range) (reflect s)
-- | Store a numeric value, with the invariant that it stays non-negative. The value set is set as a
-- dummy value if it's equal to zero.
(=:+) :: (SingI f, Num (FieldType f), CustomBounded (FieldType f), Ord (FieldType f))
=> Sing f -> FieldType f -> Attr f
s =:+ val = Attr ((if val == 0 then Dummy else Real) val) (rangeCheck (0, upperBound)) (reflect s)
-- | Get a field from a singleton
-- Adapted from: http://stackoverflow.com/a/28033250/2388535
reflect :: forall (f :: Field). (SingI f, SingKind ('KProxy :: KProxy Field)) => Sing f -> Field
reflect = fromSing
-- | A record representing an object of the Widget class from IPython
defaultWidget :: FieldType ViewName -> Rec Attr WidgetClass
@ -293,7 +359,7 @@ defaultWidget viewName = (SModelModule =:: "")
:& (SModelName =:: "WidgetModel")
:& (SViewModule =:: "")
:& (SViewName =:: viewName)
:& (SMsgThrottle =:: 3)
:& (SMsgThrottle =:+ 3)
:& (SVersion =:: 0)
:& (SOnDisplayed =:: return ())
:& RNil
@ -304,19 +370,19 @@ defaultDOMWidget viewName = defaultWidget viewName <+> domAttrs
where domAttrs = (SVisible =:: True)
:& (SCSS =:: [])
:& (SDOMClasses =:: [])
:& (SWidth =:: 0)
:& (SHeight =:: 0)
:& (SPadding =:: 0)
:& (SMargin =:: 0)
:& (SWidth =:+ 0)
:& (SHeight =:+ 0)
:& (SPadding =:+ 0)
:& (SMargin =:+ 0)
:& (SColor =:: "")
:& (SBackgroundColor =:: "")
:& (SBorderColor =:: "")
:& (SBorderWidth =:: 0)
:& (SBorderRadius =:: 0)
:& (SBorderWidth =:+ 0)
:& (SBorderRadius =:+ 0)
:& (SBorderStyle =:: DefaultBorder)
:& (SFontStyle =:: DefaultFont)
:& (SFontWeight =:: DefaultWeight)
:& (SFontSize =:: 0)
:& (SFontSize =:+ 0)
:& (SFontFamily =:: "")
:& RNil
@ -386,7 +452,7 @@ defaultIntRangeWidget viewName = defaultIntWidget viewName <+> rangeAttrs
-- | A record representing a widget of the _BoundedIntRange class from IPython
defaultBoundedIntRangeWidget :: FieldType ViewName -> Rec Attr BoundedIntRangeClass
defaultBoundedIntRangeWidget viewName = defaultIntRangeWidget viewName <+> boundedIntRangeAttrs
where boundedIntRangeAttrs = (SStepInt =:: 1)
where boundedIntRangeAttrs = (SStepInt =:+ 1)
:& (SMinInt =:: 0)
:& (SMaxInt =:: 100)
:& RNil
@ -402,7 +468,7 @@ defaultFloatWidget viewName = defaultDOMWidget viewName <+> intAttrs
-- | A record representing a widget of the _BoundedFloat class from IPython
defaultBoundedFloatWidget :: FieldType ViewName -> Rec Attr BoundedFloatClass
defaultBoundedFloatWidget viewName = defaultFloatWidget viewName <+> boundedFloatAttrs
where boundedFloatAttrs = (SStepFloat =:: 1)
where boundedFloatAttrs = (SStepFloat =:+ 1)
:& (SMinFloat =:: 0)
:& (SMaxFloat =:: 100)
:& RNil
@ -418,7 +484,7 @@ defaultFloatRangeWidget viewName = defaultFloatWidget viewName <+> rangeAttrs
-- | A record representing a widget of the _BoundedFloatRange class from IPython
defaultBoundedFloatRangeWidget :: FieldType ViewName -> Rec Attr BoundedFloatRangeClass
defaultBoundedFloatRangeWidget viewName = defaultFloatRangeWidget viewName <+> boundedFloatRangeAttrs
where boundedFloatRangeAttrs = (SStepFloat =:: 1)
where boundedFloatRangeAttrs = (SStepFloat =:+ 1)
:& (SMinFloat =:: 0)
:& (SMaxFloat =:: 100)
:& RNil
@ -437,27 +503,38 @@ instance RecAll Attr (WidgetFields w) ToPairs => ToJSON (WidgetState w) where
data IPythonWidget (w :: WidgetType) = IPythonWidget { uuid :: UUID, state :: IORef (WidgetState w) }
-- | Change the value for a field, and notify the frontend about it.
setField :: (f ∈ WidgetFields w, IHaskellWidget (IPythonWidget w), ToPairs (Attr f)) => IPythonWidget w -> SField f -> FieldType f -> IO ()
setField widget (sfield :: SField f) fval = do
setField' widget sfield fval
let pairs = toPairs (Attr fval :: Attr f)
when (not . null $ pairs) $ widgetSendUpdate widget (object pairs)
setField :: (f ∈ WidgetFields w, IHaskellWidget (IPythonWidget w), ToPairs (Attr f))
=> IPythonWidget w -> SField f -> FieldType f -> IO ()
setField widget sfield fval = do
!newattr <- setField' widget sfield fval
let pairs = toPairs newattr
unless (null pairs) $ widgetSendUpdate widget (object pairs)
-- | Change the value of a field, without notifying the frontend. For internal use. Uses BangPattern.
setField' :: (f ∈ WidgetFields w, IHaskellWidget (IPythonWidget w)) => IPythonWidget w -> SField f -> FieldType f -> IO ()
setField' widget sfield !fval = modifyIORef (state widget) (WidgetState . rput (sfield =:: fval) . _getState)
-- | Change the value of a field, without notifying the frontend. For internal use.
setField' :: (f ∈ WidgetFields w, IHaskellWidget (IPythonWidget w))
=> IPythonWidget w -> SField f -> FieldType f -> IO (Attr f)
setField' widget sfield val = do
attr <- getAttr widget sfield
newval <- _verify attr val
let newattr = attr { _value = Real newval }
modifyIORef (state widget) (WidgetState . rput newattr . _getState)
return newattr
-- | Pluck an attribute from a record
getAttr :: (f ∈ WidgetFields w) => IPythonWidget w -> SField f -> IO (Attr f)
getAttr widget sfield = rget sfield <$> _getState <$> readIORef (state widget)
-- | Get the value of a field.
getField :: (f ∈ WidgetFields w) => IPythonWidget w -> SField f -> IO (FieldType f)
getField widget sfield = _unAttr <$> rget sfield <$> _getState <$> readIORef (state widget)
getField widget sfield = unwrap . _value <$> getAttr widget sfield
-- | Useful with toJSON and OverloadedStrings
str :: String -> String
str = id
-- | Send zero values as empty strings, which stands for default value in the frontend.
-- Sending non-zero naturals as strings causes issues in the frontend. Specifically, addition
-- becomes string concatenation which creates problems in {Int|Float}RangeSlider.
instance ToJSON Natural where
toJSON 0 = String ""
toJSON n = Number . fromInteger $ toInteger n
properties :: IPythonWidget w -> IO [Field]
properties widget = do
st <- readIORef $ state widget
let convert :: Attr f -> Const Field f
convert attr = Const { getConst = _field attr }
return $ recordToList . rmap convert . _getState $ st