ihaskell-widgets-0.2.3.3: src/IHaskell/Display/Widgets/Types.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE AutoDeriveTypeable #-}
{-# LANGUAGE CPP #-}
-- | This module houses all the type-trickery needed to make widgets happen.
--
-- All widgets have a corresponding 'WidgetType', and some fields/attributes/properties as defined
-- by the 'WidgetFields' type-family.
--
-- Each widget field corresponds to a concrete haskell type, as given by the 'FieldType'
-- type-family.
--
-- Vinyl records are used to wrap together widget fields into a single 'WidgetState'.
--
-- Singletons are used as a way to represent the promoted types of kind Field. For example:
--
-- @
-- SViewName :: SField ViewName
-- @
--
-- This allows the user to pass the type 'ViewName' without using Data.Proxy. In essence, a
-- singleton is the only inhabitant (other than bottom) of a promoted type. Single element set/type
-- == singleton.
--
-- It also allows the record to wrap values of properties with information about their Field type. A
-- vinyl record is represented as @Rec f ts@, which means that a record is a list of @f x@, where
-- @x@ 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. Some numbers
-- need to be sent as numbers (represented by @Integer@), whereas some (css lengths) need to be sent
-- as Strings (@PixCount@).
--
-- Child widgets are expected to be sent as strings of the form "IPY_MODEL_<uuid>", where @<uuid>@
-- represents the uuid of the widget's comm.
--
-- To know more about the IPython messaging specification (as implemented in this package) take a
-- look at the supplied MsgSpec.md.
--
-- Widgets are not able to do console input, the reason for that can be found in the messaging
-- specification.
module IHaskell.Display.Widgets.Types where
import Control.Monad (unless, join, when, void)
import Control.Applicative ((<$>))
import qualified Control.Exception as Ex
import Data.Typeable (Typeable, TypeRep, typeOf)
import Data.IORef (IORef, readIORef, modifyIORef)
import Data.Text (Text, pack)
import System.IO.Error
import System.Posix.IO
import Text.Printf (printf)
import Data.Aeson hiding (pairs)
import Data.Aeson.Types (Pair)
import Data.Int (Int16)
#if MIN_VERSION_vinyl(0,9,0)
import Data.Vinyl (Rec(..), Dict(..))
import Data.Vinyl.Recursive ((<+>), recordToList, reifyConstraint, rmap)
#else
import Data.Vinyl (Rec(..), (<+>), recordToList, reifyConstraint, rmap, Dict(..))
#endif
import Data.Vinyl.Functor (Compose(..), Const(..))
import Data.Vinyl.Lens (rget, rput, type (∈))
import Data.Vinyl.TypeLevel (RecAll)
#if MIN_VERSION_singletons(2,4,0)
import Data.Singletons.Prelude.List
#else
import Data.Singletons.Prelude ((:++))
#endif
import Data.Singletons.TH
import GHC.IO.Exception
import IHaskell.Eval.Widgets (widgetSendUpdate)
import IHaskell.Display (Base64, IHaskellWidget(..))
import IHaskell.IPython.Message.UUID
import IHaskell.Display.Widgets.Singletons (Field, SField)
import qualified IHaskell.Display.Widgets.Singletons as S
import IHaskell.Display.Widgets.Common
#if MIN_VERSION_singletons(2,4,0)
-- Versions of the "singletons" package are tightly tied to the GHC version.
-- Singletons versions 2.3.* and earlier used the type level operator ':++'
-- for appending type level lists while 2.4.* and latter use the normal value
-- level list append operator '++'.
-- To maintain compatibility across GHC versions we keep using the ':++'
-- operator for now.
type (a :++ b) = a ++ b
#endif
-- Classes from IPython's widget hierarchy. Defined as such to reduce code duplication.
type WidgetClass = ['S.ViewModule, 'S.ViewName, 'S.ModelModule, 'S.ModelName,
'S.MsgThrottle, 'S.Version, 'S.DisplayHandler]
type DOMWidgetClass = WidgetClass :++ ['S.Visible, 'S.CSS, 'S.DOMClasses, 'S.Width, 'S.Height, 'S.Padding,
'S.Margin, 'S.Color, 'S.BackgroundColor, 'S.BorderColor, 'S.BorderWidth,
'S.BorderRadius, 'S.BorderStyle, 'S.FontStyle, 'S.FontWeight,
'S.FontSize, 'S.FontFamily]
type StringClass = DOMWidgetClass :++ ['S.StringValue, 'S.Disabled, 'S.Description, 'S.Placeholder]
type BoolClass = DOMWidgetClass :++ ['S.BoolValue, 'S.Disabled, 'S.Description, 'S.ChangeHandler]
type SelectionClass = DOMWidgetClass :++ ['S.Options, 'S.SelectedValue, 'S.SelectedLabel, 'S.Disabled,
'S.Description, 'S.SelectionHandler]
type MultipleSelectionClass = DOMWidgetClass :++ ['S.Options, 'S.SelectedValues, 'S.SelectedLabels, 'S.Disabled,
'S.Description, 'S.SelectionHandler]
type IntClass = DOMWidgetClass :++ ['S.IntValue, 'S.Disabled, 'S.Description, 'S.ChangeHandler]
type BoundedIntClass = IntClass :++ ['S.StepInt, 'S.MinInt, 'S.MaxInt]
type IntRangeClass = IntClass :++ ['S.IntPairValue, 'S.LowerInt, 'S.UpperInt]
type BoundedIntRangeClass = IntRangeClass :++ ['S.StepInt, 'S.MinInt, 'S.MaxInt]
type FloatClass = DOMWidgetClass :++ ['S.FloatValue, 'S.Disabled, 'S.Description, 'S.ChangeHandler]
type BoundedFloatClass = FloatClass :++ ['S.StepFloat, 'S.MinFloat, 'S.MaxFloat]
type FloatRangeClass = FloatClass :++ ['S.FloatPairValue, 'S.LowerFloat, 'S.UpperFloat]
type BoundedFloatRangeClass = FloatRangeClass :++ ['S.StepFloat, 'S.MinFloat, 'S.MaxFloat]
type BoxClass = DOMWidgetClass :++ ['S.Children, 'S.OverflowX, 'S.OverflowY, 'S.BoxStyle]
type SelectionContainerClass = BoxClass :++ ['S.Titles, 'S.SelectedIndex, 'S.ChangeHandler]
-- Types associated with Fields.
type family FieldType (f :: Field) :: * where
FieldType 'S.ViewModule = Text
FieldType 'S.ViewName = Text
FieldType 'S.ModelModule = Text
FieldType 'S.ModelName = Text
FieldType 'S.MsgThrottle = Integer
FieldType 'S.Version = Integer
FieldType 'S.DisplayHandler = IO ()
FieldType 'S.Visible = Bool
FieldType 'S.CSS = [(Text, Text, Text)]
FieldType 'S.DOMClasses = [Text]
FieldType 'S.Width = PixCount
FieldType 'S.Height = PixCount
FieldType 'S.Padding = PixCount
FieldType 'S.Margin = PixCount
FieldType 'S.Color = Text
FieldType 'S.BackgroundColor = Text
FieldType 'S.BorderColor = Text
FieldType 'S.BorderWidth = PixCount
FieldType 'S.BorderRadius = PixCount
FieldType 'S.BorderStyle = BorderStyleValue
FieldType 'S.FontStyle = FontStyleValue
FieldType 'S.FontWeight = FontWeightValue
FieldType 'S.FontSize = PixCount
FieldType 'S.FontFamily = Text
FieldType 'S.Description = Text
FieldType 'S.ClickHandler = IO ()
FieldType 'S.SubmitHandler = IO ()
FieldType 'S.Disabled = Bool
FieldType 'S.StringValue = Text
FieldType 'S.Placeholder = Text
FieldType 'S.Tooltip = Text
FieldType 'S.Icon = Text
FieldType 'S.ButtonStyle = ButtonStyleValue
FieldType 'S.B64Value = Base64
FieldType 'S.ImageFormat = ImageFormatValue
FieldType 'S.BoolValue = Bool
FieldType 'S.Options = SelectionOptions
FieldType 'S.SelectedLabel = Text
FieldType 'S.SelectedValue = Text
FieldType 'S.SelectionHandler = IO ()
FieldType 'S.Tooltips = [Text]
FieldType 'S.Icons = [Text]
FieldType 'S.SelectedLabels = [Text]
FieldType 'S.SelectedValues = [Text]
FieldType 'S.IntValue = Integer
FieldType 'S.StepInt = Integer
FieldType 'S.MinInt = Integer
FieldType 'S.MaxInt = Integer
FieldType 'S.LowerInt = Integer
FieldType 'S.UpperInt = Integer
FieldType 'S.IntPairValue = (Integer, Integer)
FieldType 'S.Orientation = OrientationValue
FieldType 'S.ShowRange = Bool
FieldType 'S.ReadOut = Bool
FieldType 'S.SliderColor = Text
FieldType 'S.BarStyle = BarStyleValue
FieldType 'S.FloatValue = Double
FieldType 'S.StepFloat = Double
FieldType 'S.MinFloat = Double
FieldType 'S.MaxFloat = Double
FieldType 'S.LowerFloat = Double
FieldType 'S.UpperFloat = Double
FieldType 'S.FloatPairValue = (Double, Double)
FieldType 'S.ChangeHandler = IO ()
FieldType 'S.Children = [ChildWidget]
FieldType 'S.OverflowX = OverflowValue
FieldType 'S.OverflowY = OverflowValue
FieldType 'S.BoxStyle = BoxStyleValue
FieldType 'S.Flex = Int
FieldType 'S.Pack = LocationValue
FieldType 'S.Align = LocationValue
FieldType 'S.Titles = [Text]
FieldType 'S.SelectedIndex = Integer
FieldType 'S.ReadOutMsg = Text
FieldType 'S.Child = Maybe ChildWidget
FieldType 'S.Selector = Text
-- | Can be used to put different widgets in a list. Useful for dealing with children widgets.
data ChildWidget = forall w. RecAll Attr (WidgetFields w) ToPairs => ChildWidget (IPythonWidget w)
instance ToJSON ChildWidget where
toJSON (ChildWidget x) = toJSON . pack $ "IPY_MODEL_" ++ uuidToString (uuid x)
-- 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 PixCount where
lowerBound = - fromIntegral (maxBound :: Int16)
upperBound = fromIntegral (maxBound :: Int16)
instance CustomBounded Integer where
lowerBound = - fromIntegral (maxBound :: Int16)
upperBound = fromIntegral (maxBound :: Int16)
instance CustomBounded Double where
lowerBound = - fromIntegral (maxBound :: Int16)
upperBound = fromIntegral (maxBound :: Int16)
-- Different types of widgets. Every widget in IPython has a corresponding WidgetType
data WidgetType = ButtonType
| ImageType
| OutputType
| HTMLType
| LabelType
| TextType
| TextAreaType
| CheckBoxType
| ToggleButtonType
| ValidType
| DropdownType
| RadioButtonsType
| SelectType
| ToggleButtonsType
| SelectMultipleType
| IntTextType
| BoundedIntTextType
| IntSliderType
| IntProgressType
| IntRangeSliderType
| FloatTextType
| BoundedFloatTextType
| FloatSliderType
| FloatProgressType
| FloatRangeSliderType
| BoxType
| AccordionType
| TabType
-- Fields associated with a widget
type family WidgetFields (w :: WidgetType) :: [Field] where
WidgetFields 'ButtonType =
DOMWidgetClass :++
['S.Description, 'S.Tooltip, 'S.Disabled, 'S.Icon, 'S.ButtonStyle
,'S.ClickHandler
]
WidgetFields 'ImageType =
DOMWidgetClass :++ ['S.ImageFormat, 'S.Width, 'S.Height, 'S.B64Value]
WidgetFields 'OutputType = DOMWidgetClass
WidgetFields 'HTMLType = StringClass
WidgetFields 'LabelType = StringClass
WidgetFields 'TextType =
StringClass :++ ['S.SubmitHandler, 'S.ChangeHandler]
-- Type level lists with a single element need both the list and the
-- constructor ticked, and a space between the open square bracket and
-- the first constructor. See https://ghc.haskell.org/trac/ghc/ticket/15601
WidgetFields 'TextAreaType = StringClass :++ '[ 'S.ChangeHandler]
WidgetFields 'CheckBoxType = BoolClass
WidgetFields 'ToggleButtonType =
BoolClass :++ ['S.Tooltip, 'S.Icon, 'S.ButtonStyle]
WidgetFields 'ValidType = BoolClass :++ '[ 'S.ReadOutMsg]
WidgetFields 'DropdownType = SelectionClass :++ '[ 'S.ButtonStyle]
WidgetFields 'RadioButtonsType = SelectionClass
WidgetFields 'SelectType = SelectionClass
WidgetFields 'ToggleButtonsType =
SelectionClass :++ ['S.Tooltips, 'S.Icons, 'S.ButtonStyle]
WidgetFields 'SelectMultipleType = MultipleSelectionClass
WidgetFields 'IntTextType = IntClass
WidgetFields 'BoundedIntTextType = BoundedIntClass
WidgetFields 'IntSliderType =
BoundedIntClass :++
['S.Orientation, 'S.ShowRange, 'S.ReadOut, 'S.SliderColor]
WidgetFields 'IntProgressType =
BoundedIntClass :++ ['S.Orientation, 'S.BarStyle]
WidgetFields 'IntRangeSliderType =
BoundedIntRangeClass :++
['S.Orientation, 'S.ShowRange, 'S.ReadOut, 'S.SliderColor]
WidgetFields 'FloatTextType = FloatClass
WidgetFields 'BoundedFloatTextType = BoundedFloatClass
WidgetFields 'FloatSliderType =
BoundedFloatClass :++
['S.Orientation, 'S.ShowRange, 'S.ReadOut, 'S.SliderColor]
WidgetFields 'FloatProgressType =
BoundedFloatClass :++ ['S.Orientation, 'S.BarStyle]
WidgetFields 'FloatRangeSliderType =
BoundedFloatRangeClass :++
['S.Orientation, 'S.ShowRange, 'S.ReadOut, 'S.SliderColor]
WidgetFields 'BoxType = BoxClass
WidgetFields 'AccordionType = SelectionContainerClass
WidgetFields 'TabType = SelectionContainerClass
-- 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) where
Attr :: Typeable (FieldType f)
=> { _value :: AttrVal (FieldType f)
, _verify :: FieldType f -> IO (FieldType f)
, _field :: Field
} -> Attr f
getFieldType :: Attr f -> TypeRep
getFieldType Attr { _value = attrval } = typeOf $ unwrap attrval
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 'S.ViewModule) where
toPairs x = ["_view_module" .= toJSON x]
instance ToPairs (Attr 'S.ViewName) where
toPairs x = ["_view_name" .= toJSON x]
instance ToPairs (Attr 'S.ModelModule) where
toPairs x = ["_model_module" .= toJSON x]
instance ToPairs (Attr 'S.ModelName) where
toPairs x = ["_model_name" .= toJSON x]
instance ToPairs (Attr 'S.MsgThrottle) where
toPairs x = ["msg_throttle" .= toJSON x]
instance ToPairs (Attr 'S.Version) where
toPairs x = ["version" .= toJSON x]
instance ToPairs (Attr 'S.DisplayHandler) where
toPairs _ = [] -- Not sent to the frontend
instance ToPairs (Attr 'S.Visible) where
toPairs x = ["visible" .= toJSON x]
instance ToPairs (Attr 'S.CSS) where
toPairs x = ["_css" .= toJSON x]
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.Padding) where
toPairs x = ["padding" .= toJSON x]
instance ToPairs (Attr 'S.Margin) where
toPairs x = ["margin" .= toJSON x]
instance ToPairs (Attr 'S.Color) where
toPairs x = ["color" .= toJSON x]
instance ToPairs (Attr 'S.BackgroundColor) where
toPairs x = ["background_color" .= toJSON x]
instance ToPairs (Attr 'S.BorderColor) where
toPairs x = ["border_color" .= toJSON x]
instance ToPairs (Attr 'S.BorderWidth) where
toPairs x = ["border_width" .= toJSON x]
instance ToPairs (Attr 'S.BorderRadius) where
toPairs x = ["border_radius" .= toJSON x]
instance ToPairs (Attr 'S.BorderStyle) where
toPairs x = ["border_style" .= toJSON x]
instance ToPairs (Attr 'S.FontStyle) where
toPairs x = ["font_style" .= toJSON x]
instance ToPairs (Attr 'S.FontWeight) where
toPairs x = ["font_weight" .= toJSON x]
instance ToPairs (Attr 'S.FontSize) where
toPairs x = ["font_size" .= toJSON x]
instance ToPairs (Attr 'S.FontFamily) where
toPairs x = ["font_family" .= 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 ToPairs (Attr 'S.B64Value) where
toPairs x = ["_b64value" .= toJSON x]
instance ToPairs (Attr 'S.ImageFormat) where
toPairs x = ["format" .= toJSON x]
instance ToPairs (Attr 'S.BoolValue) where
toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr 'S.SelectedLabel) where
toPairs x = ["selected_label" .= toJSON x]
instance ToPairs (Attr 'S.SelectedValue) where
toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr 'S.Options) where
toPairs x =
case _value x of
Dummy _ -> labels ("" :: Text)
Real (OptionLabels xs) -> labels xs
Real (OptionDict xps) -> labels $ map fst xps
where
labels xs = ["_options_labels" .= xs]
instance ToPairs (Attr 'S.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.SelectedLabels) where
toPairs x = ["selected_labels" .= toJSON x]
instance ToPairs (Attr 'S.SelectedValues) where
toPairs x = ["values" .= 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.ShowRange) where
toPairs x = ["_range" .= toJSON x]
instance ToPairs (Attr 'S.ReadOut) where
toPairs x = ["readout" .= toJSON x]
instance ToPairs (Attr 'S.SliderColor) where
toPairs x = ["slider_color" .= 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.OverflowX) where
toPairs x = ["overflow_x" .= toJSON x]
instance ToPairs (Attr 'S.OverflowY) where
toPairs x = ["overflow_y" .= toJSON x]
instance ToPairs (Attr 'S.BoxStyle) where
toPairs x = ["box_style" .= toJSON x]
instance ToPairs (Attr 'S.Flex) where
toPairs x = ["flex" .= 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.Child) where
toPairs x = ["child" .= toJSON x]
instance ToPairs (Attr 'S.Selector) where
toPairs x = ["selector" .= 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
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
| otherwise = error "The impossible happened in IHaskell.Display.Widgets.Types.rangeCheck"
-- | Store a numeric value, with verification mechanism for its range.
ranged :: (SingI f, Num (FieldType f), Ord (FieldType f), Typeable (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), Typeable (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) => Sing f -> Field
reflect = fromSing
-- | A record representing an object of the Widget class from IPython
defaultWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr WidgetClass
defaultWidget viewName modelName = (ViewModule =:: "jupyter-js-widgets")
:& (ViewName =:: viewName)
:& (ModelModule =:: "jupyter-js-widgets")
:& (ModelName =:: modelName)
:& (MsgThrottle =:+ 3)
:& (Version =:: 0)
:& (DisplayHandler =:: return ())
:& RNil
-- | A record representing an object of the DOMWidget class from IPython
defaultDOMWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr DOMWidgetClass
defaultDOMWidget viewName modelName = defaultWidget viewName modelName <+> domAttrs
where
domAttrs = (Visible =:: True)
:& (CSS =:: [])
:& (DOMClasses =:: [])
:& (Width =:+ 0)
:& (Height =:+ 0)
:& (Padding =:+ 0)
:& (Margin =:+ 0)
:& (Color =:: "")
:& (BackgroundColor =:: "")
:& (BorderColor =:: "")
:& (BorderWidth =:+ 0)
:& (BorderRadius =:+ 0)
:& (BorderStyle =:: DefaultBorder)
:& (FontStyle =:: DefaultFont)
:& (FontWeight =:: DefaultWeight)
:& (FontSize =:+ 0)
:& (FontFamily =:: "")
:& RNil
-- | A record representing a widget of the _String class from IPython
defaultStringWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr StringClass
defaultStringWidget viewName modelName = defaultDOMWidget viewName modelName <+> strAttrs
where
strAttrs = (StringValue =:: "")
:& (Disabled =:: False)
:& (Description =:: "")
:& (Placeholder =:: "")
:& RNil
-- | A record representing a widget of the _Bool class from IPython
defaultBoolWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr BoolClass
defaultBoolWidget viewName modelName = defaultDOMWidget viewName modelName <+> boolAttrs
where
boolAttrs = (BoolValue =:: False)
:& (Disabled =:: False)
:& (Description =:: "")
:& (ChangeHandler =:: return ())
:& RNil
-- | A record representing a widget of the _Selection class from IPython
defaultSelectionWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr SelectionClass
defaultSelectionWidget viewName modelName = defaultDOMWidget viewName modelName <+> selectionAttrs
where
selectionAttrs = (Options =:: OptionLabels [])
:& (SelectedValue =:: "")
:& (SelectedLabel =:: "")
:& (Disabled =:: False)
:& (Description =:: "")
:& (SelectionHandler =:: return ())
:& RNil
-- | A record representing a widget of the _MultipleSelection class from IPython
defaultMultipleSelectionWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr MultipleSelectionClass
defaultMultipleSelectionWidget viewName modelName = defaultDOMWidget viewName modelName <+> mulSelAttrs
where
mulSelAttrs = (Options =:: OptionLabels [])
:& (SelectedValues =:: [])
:& (SelectedLabels =:: [])
:& (Disabled =:: False)
:& (Description =:: "")
:& (SelectionHandler =:: return ())
:& RNil
-- | A record representing a widget of the _Int class from IPython
defaultIntWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr IntClass
defaultIntWidget viewName modelName = defaultDOMWidget viewName modelName <+> intAttrs
where
intAttrs = (IntValue =:: 0)
:& (Disabled =:: False)
:& (Description =:: "")
:& (ChangeHandler =:: return ())
:& RNil
-- | A record representing a widget of the _BoundedInt class from IPython
defaultBoundedIntWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr BoundedIntClass
defaultBoundedIntWidget viewName modelName = defaultIntWidget viewName modelName <+> boundedIntAttrs
where
boundedIntAttrs = (StepInt =:: 1)
:& (MinInt =:: 0)
:& (MaxInt =:: 100)
:& RNil
-- | A record representing a widget of the _BoundedInt class from IPython
defaultIntRangeWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr IntRangeClass
defaultIntRangeWidget viewName modelName = defaultIntWidget viewName modelName <+> rangeAttrs
where
rangeAttrs = (IntPairValue =:: (25, 75))
:& (LowerInt =:: 0)
:& (UpperInt =:: 100)
:& RNil
-- | A record representing a widget of the _BoundedIntRange class from IPython
defaultBoundedIntRangeWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr BoundedIntRangeClass
defaultBoundedIntRangeWidget viewName modelName = defaultIntRangeWidget viewName modelName <+> boundedIntRangeAttrs
where
boundedIntRangeAttrs = (StepInt =:+ 1)
:& (MinInt =:: 0)
:& (MaxInt =:: 100)
:& RNil
-- | A record representing a widget of the _Float class from IPython
defaultFloatWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr FloatClass
defaultFloatWidget viewName modelName = defaultDOMWidget viewName modelName <+> intAttrs
where
intAttrs = (FloatValue =:: 0)
:& (Disabled =:: False)
:& (Description =:: "")
:& (ChangeHandler =:: return ())
:& RNil
-- | A record representing a widget of the _BoundedFloat class from IPython
defaultBoundedFloatWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr BoundedFloatClass
defaultBoundedFloatWidget viewName modelName = defaultFloatWidget viewName modelName <+> boundedFloatAttrs
where
boundedFloatAttrs = (StepFloat =:+ 1)
:& (MinFloat =:: 0)
:& (MaxFloat =:: 100)
:& RNil
-- | A record representing a widget of the _BoundedFloat class from IPython
defaultFloatRangeWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr FloatRangeClass
defaultFloatRangeWidget viewName modelName = defaultFloatWidget viewName modelName <+> rangeAttrs
where
rangeAttrs = (FloatPairValue =:: (25, 75))
:& (LowerFloat =:: 0)
:& (UpperFloat =:: 100)
:& RNil
-- | A record representing a widget of the _BoundedFloatRange class from IPython
defaultBoundedFloatRangeWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr BoundedFloatRangeClass
defaultBoundedFloatRangeWidget viewName modelName = defaultFloatRangeWidget viewName modelName <+> boundedFloatRangeAttrs
where
boundedFloatRangeAttrs = (StepFloat =:+ 1)
:& (MinFloat =:: 0)
:& (MaxFloat =:: 100)
:& RNil
-- | A record representing a widget of the _Box class from IPython
defaultBoxWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr BoxClass
defaultBoxWidget viewName modelName = defaultDOMWidget viewName modelName <+> intAttrs
where
intAttrs = (Children =:: [])
:& (OverflowX =:: DefaultOverflow)
:& (OverflowY =:: DefaultOverflow)
:& (BoxStyle =:: DefaultBox)
:& RNil
-- | A record representing a widget of the _SelectionContainer class from IPython
defaultSelectionContainerWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr SelectionContainerClass
defaultSelectionContainerWidget viewName modelName = defaultBoxWidget viewName modelName <+> selAttrs
where
selAttrs = (Titles =:: [])
:& (SelectedIndex =:: 0)
:& (ChangeHandler =:: 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.
instance RecAll Attr (WidgetFields w) ToPairs => ToJSON (WidgetState w) where
toJSON record =
object
. concat
. recordToList
. rmap (\(Compose (Dict x)) -> Const $ toPairs x) $ reifyConstraint (Proxy :: Proxy ToPairs) $ _getState
record
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 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.
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)
#if MIN_VERSION_vinyl(0,9,0)
getAttr widget _ = rget <$> _getState <$> readIORef (state widget)
#else
getAttr widget sfield = rget sfield <$> _getState <$> readIORef (state widget)
#endif
-- | Get the value of a field.
getField :: (f ∈ WidgetFields w) => IPythonWidget w -> SField f -> IO (FieldType f)
getField widget sfield = unwrap . _value <$> getAttr widget sfield
-- | Useful with toJSON and OverloadedStrings
str :: String -> String
str = id
properties :: IPythonWidget w -> IO ()
properties widget = do
st <- readIORef $ state widget
let convert :: Attr f -> Const (Field, TypeRep) f
convert attr = Const (_field attr, getFieldType attr)
renderRow (fname, ftype) = printf "%s ::: %s" (show fname) (show ftype)
rows = map renderRow . recordToList . rmap convert $ _getState st
mapM_ putStrLn rows
-- Helper function for widget to enforce their inability to fetch console input
noStdin :: IO a -> IO ()
noStdin action =
let handler :: IOException -> IO ()
handler e = when (ioeGetErrorType e == InvalidArgument)
(error "Widgets cannot do console input, sorry :)")
in Ex.handle handler $ do
nullFd <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags
oldStdin <- dup stdInput
void $ dupTo nullFd stdInput
closeFd nullFd
void action
void $ dupTo oldStdin stdInput
-- Trigger events
triggerEvent :: (FieldType f ~ IO (), f ∈ WidgetFields w) => SField f -> IPythonWidget w -> IO ()
triggerEvent sfield w = noStdin . join $ getField w sfield
triggerChange :: ('S.ChangeHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerChange = triggerEvent ChangeHandler
triggerClick :: ('S.ClickHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerClick = triggerEvent ClickHandler
triggerSelection :: ('S.SelectionHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerSelection = triggerEvent SelectionHandler
triggerSubmit :: ('S.SubmitHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerSubmit = triggerEvent SubmitHandler
triggerDisplay :: ('S.DisplayHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerDisplay = triggerEvent DisplayHandler