ihaskell-widgets-0.4.0.0: 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 #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- | 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,mzero)
import Control.Applicative ((<$>))
import qualified Control.Exception as Ex
import Data.Typeable (Typeable, TypeRep, typeOf)
import Data.IORef (IORef, readIORef, modifyIORef)
import Data.String
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.ByteString (ByteString)
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(3,0,0)
import Data.List.Singletons
#elif MIN_VERSION_singletons(2,4,0)
import Data.Singletons.Prelude.List
#else
import Data.Singletons.Prelude ((:++))
#endif
#if MIN_VERSION_singletons(3,0,0)
import Data.Singletons.Base.TH
#else
import Data.Singletons.TH
#endif
import Data.Text.Lazy (unpack)
import Data.Text.Lazy.Encoding
import GHC.IO.Exception
import IHaskell.Eval.Widgets (widgetSendUpdate, widgetSendView)
import IHaskell.Display (IHaskellWidget(..), IHaskellDisplay(..), Display(..), widgetdisplay, base64)
import IHaskell.IPython.Types (StreamType(..))
import IHaskell.IPython.Message.UUID
import IHaskell.Display.Widgets.Singletons (Field, SField, toKey, HasKey)
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 CoreWidgetClass = ['S.ViewModule, 'S.ViewModuleVersion, 'S.ModelModule, 'S.ModelModuleVersion ]
type DOMWidgetClass = ['S.ModelName, 'S.ViewName, 'S.DOMClasses, 'S.Tooltip, 'S.Layout, 'S.DisplayHandler]
type StyleWidgetClass = ['S.ModelName, 'S.ViewName] :++ CoreWidgetClass
type DescriptionWidgetClass = CoreWidgetClass :++ DOMWidgetClass :++ ['S.Description,'S.Style]
type StringClass = DescriptionWidgetClass :++ ['S.StringValue, 'S.Placeholder]
type TextClass = StringClass :++ [ 'S.Disabled, 'S.ContinuousUpdate, 'S.SubmitHandler, 'S.ChangeHandler]
type BoolClass = DescriptionWidgetClass :++ ['S.BoolValue, 'S.Disabled, 'S.ChangeHandler]
type SelectionClass = DescriptionWidgetClass :++ ['S.OptionsLabels, 'S.OptionalIndex, 'S.Disabled, 'S.SelectionHandler]
type SelectionNonemptyClass = DescriptionWidgetClass :++ ['S.OptionsLabels, 'S.Index, 'S.Disabled, 'S.SelectionHandler]
type MultipleSelectionClass = DescriptionWidgetClass :++ ['S.OptionsLabels, 'S.Indices, 'S.Disabled, 'S.SelectionHandler]
type IntClass = DescriptionWidgetClass :++ [ 'S.IntValue, 'S.ChangeHandler ]
type BoundedIntClass = IntClass :++ ['S.MaxInt, 'S.MinInt]
type IntRangeClass = IntClass :++ ['S.IntPairValue, 'S.LowerInt, 'S.UpperInt]
type BoundedIntRangeClass = IntRangeClass :++ ['S.MaxInt, 'S.MinInt]
type FloatClass = DescriptionWidgetClass :++ [ 'S.FloatValue, 'S.ChangeHandler ]
type BoundedFloatClass = FloatClass :++ ['S.MinFloat, 'S.MaxFloat]
type BoundedLogFloatClass = FloatClass :++ [ 'S.MinFloat, 'S.MaxFloat, 'S.BaseFloat ]
type FloatRangeClass = FloatClass :++ '[ 'S.FloatPairValue ]
type BoundedFloatRangeClass = FloatRangeClass :++ ['S.StepFloat, 'S.MinFloat, 'S.MaxFloat]
type BoxClass = CoreWidgetClass :++ DOMWidgetClass :++ ['S.Children, 'S.BoxStyle]
type SelectionContainerClass = BoxClass :++ ['S.Titles, 'S.SelectedIndex, 'S.ChangeHandler]
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) :: *
type instance FieldType 'S.ViewModule = Text
type instance FieldType 'S.ViewModuleVersion = Text
type instance FieldType 'S.ViewName = Text
type instance FieldType 'S.ModelModule = Text
type instance FieldType 'S.ModelModuleVersion = Text
type instance FieldType 'S.ModelName = Text
type instance FieldType 'S.Layout = IPythonWidget 'LayoutType
type instance FieldType 'S.DisplayHandler = IO ()
type instance FieldType 'S.DOMClasses = [Text]
type instance FieldType 'S.Width = PixCount
type instance FieldType 'S.Height = PixCount
type instance FieldType 'S.Description = Text
type instance FieldType 'S.ClickHandler = IO ()
type instance FieldType 'S.SubmitHandler = IO ()
type instance FieldType 'S.Disabled = Bool
type instance FieldType 'S.StringValue = Text
type instance FieldType 'S.Placeholder = Text
type instance FieldType 'S.Tooltip = Maybe Text
type instance FieldType 'S.Icon = Text
type instance FieldType 'S.ButtonStyle = ButtonStyleValue
type instance FieldType 'S.BSValue = JSONByteString
type instance FieldType 'S.ImageFormat = ImageFormatValue
type instance FieldType 'S.BoolValue = Bool
type instance FieldType 'S.OptionsLabels = [Text]
type instance FieldType 'S.Index = Integer
type instance FieldType 'S.OptionalIndex = Maybe Integer
type instance FieldType 'S.SelectionHandler = IO ()
type instance FieldType 'S.Tooltips = [Text]
type instance FieldType 'S.Icons = [Text]
type instance FieldType 'S.Indices = [Integer]
type instance FieldType 'S.IntValue = Integer
type instance FieldType 'S.StepInt = Maybe Integer
type instance FieldType 'S.MinInt = Integer
type instance FieldType 'S.MaxInt = Integer
type instance FieldType 'S.LowerInt = Integer
type instance FieldType 'S.UpperInt = Integer
type instance FieldType 'S.IntPairValue = (Integer, Integer)
type instance FieldType 'S.Orientation = OrientationValue
type instance FieldType 'S.BaseFloat = Double
type instance FieldType 'S.ReadOut = Bool
type instance FieldType 'S.ReadOutFormat = Text
type instance FieldType 'S.BarStyle = BarStyleValue
type instance FieldType 'S.FloatValue = Double
type instance FieldType 'S.StepFloat = Maybe Double
type instance FieldType 'S.MinFloat = Double
type instance FieldType 'S.MaxFloat = Double
type instance FieldType 'S.LowerFloat = Double
type instance FieldType 'S.UpperFloat = Double
type instance FieldType 'S.FloatPairValue = (Double, Double)
type instance FieldType 'S.ChangeHandler = IO ()
type instance FieldType 'S.Children = [ChildWidget]
type instance FieldType 'S.BoxStyle = BoxStyleValue
type instance FieldType 'S.Titles = [Text]
type instance FieldType 'S.SelectedIndex = Maybe Integer
type instance FieldType 'S.ReadOutMsg = Text
type instance FieldType 'S.Indent = Bool
type instance FieldType 'S.ContinuousUpdate = Bool
type instance FieldType 'S.Rows = Maybe Integer
type instance FieldType 'S.AudioFormat = AudioFormatValue
type instance FieldType 'S.VideoFormat = VideoFormatValue
type instance FieldType 'S.AutoPlay = Bool
type instance FieldType 'S.Loop = Bool
type instance FieldType 'S.Controls = Bool
type instance FieldType 'S.Options = [Text]
type instance FieldType 'S.EnsureOption = Bool
type instance FieldType 'S.Playing = Bool
type instance FieldType 'S.Repeat = Bool
type instance FieldType 'S.Interval = Integer
type instance FieldType 'S.ShowRepeat = Bool
type instance FieldType 'S.Concise = Bool
type instance FieldType 'S.DateValue = Date
type instance FieldType 'S.Pressed = Bool
type instance FieldType 'S.Name = Text
type instance FieldType 'S.Mapping = Text
type instance FieldType 'S.Connected = Bool
type instance FieldType 'S.Timestamp = Double
type instance FieldType 'S.Buttons = [IPythonWidget 'ControllerButtonType]
type instance FieldType 'S.Axes = [IPythonWidget 'ControllerAxisType]
type instance FieldType 'S.ButtonColor = Maybe String
type instance FieldType 'S.FontWeight = FontWeightValue
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.MsgID = Text
type instance FieldType 'S.Outputs = [OutputMsg]
type instance FieldType 'S.Style = StyleWidget
-- | 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)
-- | Can be used to put different styles in a same FieldType.
data StyleWidget = forall w. RecAll Attr (WidgetFields w) ToPairs => StyleWidget (IPythonWidget w)
instance ToJSON (IPythonWidget w) where
toJSON x = toJSON . pack $ "IPY_MODEL_" ++ uuidToString (uuid x)
instance ToJSON ChildWidget where
toJSON (ChildWidget x) = toJSON x
instance ToJSON StyleWidget where
toJSON (StyleWidget x) = toJSON 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)
-- | 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
| DatePickerType
| AudioType
| ImageType
| VideoType
| OutputType
| ComboboxType
| HTMLType
| HTMLMathType
| LabelType
| PasswordType
| TextType
| TextAreaType
| CheckBoxType
| ToggleButtonType
| ValidType
| DropdownType
| RadioButtonsType
| SelectType
| SelectionSliderType
| SelectionRangeSliderType
| ToggleButtonsType
| SelectMultipleType
| IntTextType
| BoundedIntTextType
| IntSliderType
| PlayType
| IntProgressType
| IntRangeSliderType
| FloatTextType
| BoundedFloatTextType
| FloatSliderType
| FloatLogSliderType
| FloatProgressType
| FloatRangeSliderType
| BoxType
| GridBoxType
| HBoxType
| VBoxType
| AccordionType
| TabType
| StackedType
| ControllerButtonType
| ControllerAxisType
| ControllerType
| LinkType
| DirectionalLinkType
| LayoutType
| ButtonStyleType
| DescriptionStyleType
| ProgressStyleType
| SliderStyleType
| ToggleButtonsStyleType
-- Fields associated with a widget
type family WidgetFields (w :: WidgetType) :: [Field]
type instance WidgetFields 'ButtonType =
DescriptionWidgetClass :++
['S.Disabled, 'S.Icon, 'S.ButtonStyle,'S.ClickHandler]
type instance WidgetFields 'ColorPickerType =
DescriptionWidgetClass :++
['S.StringValue, 'S.Concise, 'S.Disabled, 'S.ChangeHandler]
type instance WidgetFields 'DatePickerType =
DescriptionWidgetClass :++
['S.DateValue, 'S.Disabled, 'S.ChangeHandler]
type instance WidgetFields 'AudioType =
MediaClass :++ ['S.AudioFormat, 'S.AutoPlay, 'S.Loop, 'S.Controls]
type instance WidgetFields 'ImageType =
MediaClass :++ ['S.ImageFormat, 'S.Width, 'S.Height]
type instance WidgetFields 'VideoType =
MediaClass :++ ['S.VideoFormat, 'S.Width, 'S.Height, 'S.AutoPlay, 'S.Loop, 'S.Controls]
type instance WidgetFields 'OutputType = DOMWidgetClass :++ ['S.ViewModule,'S.ModelModule,'S.ViewModuleVersion,'S.ModelModuleVersion,'S.MsgID,'S.Outputs]
type instance WidgetFields 'HTMLType = StringClass
type instance WidgetFields 'HTMLMathType = StringClass
type instance WidgetFields 'ComboboxType = TextClass :++ [ 'S.Options, 'S.EnsureOption ]
type instance WidgetFields 'LabelType = StringClass
type instance WidgetFields 'PasswordType = TextClass
type instance WidgetFields 'TextType = TextClass
-- 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
type instance WidgetFields 'TextAreaType =
StringClass :++
[ 'S.Rows, 'S.Disabled, 'S.ContinuousUpdate, 'S.ChangeHandler]
type instance WidgetFields 'CheckBoxType = BoolClass :++ '[ 'S.Indent ]
type instance WidgetFields 'ToggleButtonType = BoolClass :++ ['S.Icon, 'S.ButtonStyle]
type instance WidgetFields 'ValidType = BoolClass :++ '[ 'S.ReadOutMsg ]
type instance WidgetFields 'DropdownType = SelectionClass
type instance WidgetFields 'RadioButtonsType = SelectionClass
type instance WidgetFields 'SelectType = SelectionClass :++ '[ 'S.Rows ]
type instance WidgetFields 'SelectionSliderType = SelectionNonemptyClass :++ '[ 'S.Orientation, 'S.ReadOut, 'S.ContinuousUpdate ]
type instance WidgetFields 'SelectionRangeSliderType = MultipleSelectionClass :++ '[ 'S.Orientation, 'S.ReadOut, 'S.ContinuousUpdate ]
type instance WidgetFields 'ToggleButtonsType =
SelectionClass :++ ['S.Tooltips, 'S.Icons, 'S.ButtonStyle]
type instance WidgetFields 'SelectMultipleType = MultipleSelectionClass :++ '[ 'S.Rows ]
type instance WidgetFields 'IntTextType = IntClass :++ [ 'S.Disabled, 'S.ContinuousUpdate, 'S.StepInt ]
type instance WidgetFields 'BoundedIntTextType = BoundedIntClass :++ [ 'S.Disabled, 'S.ContinuousUpdate, 'S.StepInt ]
type instance WidgetFields 'IntSliderType =
BoundedIntClass :++
[ 'S.StepInt, 'S.Orientation, 'S.ReadOut, 'S.ReadOutFormat, 'S.ContinuousUpdate, 'S.Disabled ]
type instance WidgetFields 'PlayType =
BoundedIntClass :++
[ 'S.Playing, 'S.Repeat, 'S.Interval, 'S.StepInt, 'S.Disabled, 'S.ShowRepeat ]
type instance WidgetFields 'IntProgressType =
BoundedIntClass :++ ['S.Orientation, 'S.BarStyle]
type instance WidgetFields 'IntRangeSliderType =
BoundedIntRangeClass :++
['S.StepInt, 'S.Orientation, 'S.ReadOut, 'S.ReadOutFormat, 'S.ContinuousUpdate, 'S.Disabled ]
type instance WidgetFields 'FloatTextType = FloatClass :++ '[ 'S.Disabled, 'S.ContinuousUpdate, 'S.StepFloat ]
type instance WidgetFields 'BoundedFloatTextType = BoundedFloatClass :++ '[ 'S.Disabled, 'S.ContinuousUpdate, 'S.StepFloat ]
type instance WidgetFields 'FloatSliderType =
BoundedFloatClass :++
['S.StepFloat, 'S.Orientation, 'S.ReadOut, 'S.ReadOutFormat, 'S.ContinuousUpdate, 'S.Disabled ]
type instance WidgetFields 'FloatLogSliderType =
BoundedLogFloatClass :++
['S.StepFloat, 'S.Orientation, 'S.ReadOut, 'S.ReadOutFormat, 'S.ContinuousUpdate, 'S.Disabled, 'S.BaseFloat]
type instance WidgetFields 'FloatProgressType =
BoundedFloatClass :++ ['S.Orientation, 'S.BarStyle]
type instance WidgetFields 'FloatRangeSliderType =
BoundedFloatRangeClass :++
['S.StepFloat, 'S.Orientation, 'S.ReadOut, 'S.ReadOutFormat, 'S.ContinuousUpdate, 'S.Disabled ]
type instance WidgetFields 'BoxType = BoxClass
type instance WidgetFields 'GridBoxType = BoxClass
type instance WidgetFields 'HBoxType = BoxClass
type instance WidgetFields 'VBoxType = BoxClass
type instance WidgetFields 'AccordionType = SelectionContainerClass
type instance WidgetFields 'TabType = SelectionContainerClass
type instance WidgetFields 'StackedType = SelectionContainerClass
type instance WidgetFields 'ControllerType =
CoreWidgetClass :++ DOMWidgetClass :++
['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
type instance WidgetFields 'ProgressStyleType = DescriptionStyleClass :++ '[ 'S.BarColor ]
type instance WidgetFields 'SliderStyleType = DescriptionStyleClass :++ '[ 'S.HandleColor ]
type instance WidgetFields 'ToggleButtonsStyleType = DescriptionStyleClass :++ ['S.ButtonWidth,'S.FontWeight]
-- 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
, _ro :: Bool
} -> 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 _ -> object []
Real x -> toJSON x
-- Types that can be converted to Aeson Pairs.
class ToPairs a where
toPairs :: a -> [Pair]
-- 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'
class hk ~ HasKey a => ToPairs' hk a where
toPairs' :: Attr a -> [Pair]
instance HasKey f ~ 'False => ToPairs' 'False f where
toPairs' _ = []
instance (ToJSON (FieldType f), HasKey f ~ 'True) => ToPairs' 'True f where
toPairs' x = [ fromString (toKey $ _field x) .= toJSON x ]
newtype JSONByteString = JSONByteString ByteString
deriving (Eq,Ord)
instance ToJSON JSONByteString where
toJSON (JSONByteString x) = toJSON $ base64 x
instance IsString JSONByteString where
fromString = JSONByteString . fromString
-- | 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, _ro = False }
-- | Store the value for a field, with a custom verification
(=:.) :: (SingI f, Typeable (FieldType f)) => Sing f -> (FieldType f, FieldType f -> IO (FieldType f) ) -> Attr f
s =:. (x,v) = Attr { _value = Real x, _verify = v, _field = reflect s, _ro = False }
-- | Store the value for a field, making it read only from the frontend
(=:!) :: (SingI f, Typeable (FieldType f)) => Sing f -> FieldType f -> Attr f
s =:! x = Attr { _value = Real x, _verify = return, _field = reflect s, _ro = True}
-- | 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"
rangeSliderVerification :: [Integer] -> IO [Integer]
rangeSliderVerification xs@[a,b]
| a <= b = return xs
| otherwise = Ex.throw $ Ex.AssertionFailed "The first index should be smaller than the second"
rangeSliderVerification _ = Ex.throw $ Ex.AssertionFailed "There should be two indices"
-- | 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) False
-- | 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)
False
-- | 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 a Widget class from IPython from the controls modules
defaultCoreWidget :: Rec Attr CoreWidgetClass
defaultCoreWidget = (ViewModule =:! "@jupyter-widgets/controls")
:& (ViewModuleVersion =:! "1.4.0")
:& (ModelModule =:! "@jupyter-widgets/controls")
:& (ModelModuleVersion =:! "1.4.0")
:& RNil
-- | A record representing an object of the DOMWidget class from IPython
defaultDOMWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> IPythonWidget 'LayoutType -> Rec Attr DOMWidgetClass
defaultDOMWidget viewName modelName layout = (ModelName =:! modelName)
:& (ViewName =:! viewName)
:& (DOMClasses =:: [])
:& (Tooltip =:: Nothing)
:& (Layout =:: layout)
:& (DisplayHandler =:: return ())
:& RNil
-- | A record representing an object of the DescriptionWidget class from IPython
defaultDescriptionWidget :: FieldType 'S.ViewName
-> FieldType 'S.ModelName
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr DescriptionWidgetClass
defaultDescriptionWidget v m l d = defaultCoreWidget <+> defaultDOMWidget v m l <+> descriptionAttrs
where
descriptionAttrs = (Description =:: "")
:& (Style =:: d)
:& RNil
-- | A record representing a widget of the _String class from IPython
defaultStringWidget :: FieldType 'S.ViewName
-> FieldType 'S.ModelName
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr StringClass
defaultStringWidget viewName modelName l d = defaultDescriptionWidget viewName modelName l d <+> strAttrs
where
strAttrs = (StringValue =:: "")
:& (Placeholder =:: "")
:& RNil
-- | A record representing a widget of the Text class from IPython
defaultTextWidget :: FieldType 'S.ViewName
-> FieldType 'S.ModelName
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr TextClass
defaultTextWidget viewName modelName l d = defaultStringWidget viewName modelName l d <+> txtAttrs
where
txtAttrs = (Disabled =:: False)
:& (ContinuousUpdate =:: True)
:& (SubmitHandler =:: return ())
:& (ChangeHandler =:: return ())
:& RNil
-- | A record representing a widget of the _Bool class from IPython
defaultBoolWidget :: FieldType 'S.ViewName
-> FieldType 'S.ModelName
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr BoolClass
defaultBoolWidget viewName modelName l d = defaultDescriptionWidget viewName modelName l d <+> boolAttrs
where
boolAttrs = (BoolValue =:: False)
:& (Disabled =:: False)
:& (ChangeHandler =:: return ())
:& RNil
-- | A record representing a widget of the _Selection class from IPython
defaultSelectionWidget :: FieldType 'S.ViewName
-> FieldType 'S.ModelName
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr SelectionClass
defaultSelectionWidget viewName modelName l d = defaultDescriptionWidget viewName modelName l d <+> selectionAttrs
where
selectionAttrs = (OptionsLabels =:: [])
:& (OptionalIndex =:: Nothing)
:& (Disabled =:: False)
:& (SelectionHandler =:: return ())
:& RNil
-- | A record representing a widget of the _SelectionNonempty class from IPython
defaultSelectionNonemptyWidget :: FieldType 'S.ViewName
-> FieldType 'S.ModelName
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr SelectionNonemptyClass
defaultSelectionNonemptyWidget viewName modelName l d = defaultDescriptionWidget viewName modelName l d <+> selectionAttrs
where
selectionAttrs = (OptionsLabels =:: [])
:& (Index =:: 0)
:& (Disabled =:: False)
:& (SelectionHandler =:: return ())
:& RNil
-- | A record representing a widget of the _MultipleSelection class from IPython
defaultMultipleSelectionWidget :: FieldType 'S.ViewName
-> FieldType 'S.ModelName
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr MultipleSelectionClass
defaultMultipleSelectionWidget viewName modelName l d = defaultDescriptionWidget viewName modelName l d <+> mulSelAttrs
where
mulSelAttrs = (OptionsLabels =:: [])
:& (Indices =:: [])
:& (Disabled =:: False)
:& (SelectionHandler =:: return ())
:& RNil
-- | A record representing a widget of the _Int class from IPython
defaultIntWidget :: FieldType 'S.ViewName
-> FieldType 'S.ModelName
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr IntClass
defaultIntWidget viewName modelName l d = defaultDescriptionWidget viewName modelName l d <+> intAttrs
where
intAttrs = (IntValue =:: 0)
:& (ChangeHandler =:: return ())
:& RNil
-- | A record representing a widget of the _BoundedInt class from IPython
defaultBoundedIntWidget :: FieldType 'S.ViewName
-> FieldType 'S.ModelName
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr BoundedIntClass
defaultBoundedIntWidget viewName modelName l d = defaultIntWidget viewName modelName l d <+> boundedIntAttrs
where
boundedIntAttrs = (MaxInt =:: 100)
:& (MinInt =:: 0)
:& RNil
-- | A record representing a widget of the _BoundedInt class from IPython
defaultIntRangeWidget :: FieldType 'S.ViewName
-> FieldType 'S.ModelName
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr IntRangeClass
defaultIntRangeWidget viewName modelName l d = defaultIntWidget viewName modelName l d <+> 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
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr BoundedIntRangeClass
defaultBoundedIntRangeWidget viewName modelName l d = defaultIntRangeWidget viewName modelName l d <+> boundedIntRangeAttrs
where
boundedIntRangeAttrs = (MaxInt =:: 100)
:& (MinInt =:: 0)
:& RNil
-- | A record representing a widget of the _Float class from IPython
defaultFloatWidget :: FieldType 'S.ViewName
-> FieldType 'S.ModelName
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr FloatClass
defaultFloatWidget viewName modelName l d = defaultDescriptionWidget viewName modelName l d <+> floatAttrs
where
floatAttrs = (FloatValue =:: 0.0)
:& (ChangeHandler =:: return ())
:& RNil
-- | A record representing a widget of the _BoundedFloat class from IPython
defaultBoundedFloatWidget :: FieldType 'S.ViewName
-> FieldType 'S.ModelName
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr BoundedFloatClass
defaultBoundedFloatWidget viewName modelName l d = defaultFloatWidget viewName modelName l d <+> boundedFloatAttrs
where
boundedFloatAttrs = (MinFloat =:: 0)
:& (MaxFloat =:: 100)
:& RNil
-- | A record representing a widget of the _BoundedLogFloat class from IPython
defaultBoundedLogFloatWidget :: FieldType 'S.ViewName
-> FieldType 'S.ModelName
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr BoundedLogFloatClass
defaultBoundedLogFloatWidget viewName modelName l d = floatAttrs <+> boundedLogFloatAttrs
where
floatAttrs = rput (FloatValue =:: 1.0) $ defaultFloatWidget viewName modelName l d
boundedLogFloatAttrs = (MinFloat =:: 0.0)
:& (MaxFloat =:: 4.0)
:& (BaseFloat =:: 10.0)
:& RNil
-- | A record representing a widget of the _BoundedFloat class from IPython
defaultFloatRangeWidget :: FieldType 'S.ViewName
-> FieldType 'S.ModelName
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr FloatRangeClass
defaultFloatRangeWidget viewName modelName l d = defaultFloatWidget viewName modelName l d <+> rangeAttrs
where
rangeAttrs = (FloatPairValue =:: (0.0, 1.0))
:& RNil
-- | A record representing a widget of the _BoundedFloatRange class from IPython
defaultBoundedFloatRangeWidget :: FieldType 'S.ViewName
-> FieldType 'S.ModelName
-> IPythonWidget 'LayoutType
-> StyleWidget
-> Rec Attr BoundedFloatRangeClass
defaultBoundedFloatRangeWidget viewName modelName l d = defaultFloatRangeWidget viewName modelName l d <+> boundedFloatRangeAttrs
where
boundedFloatRangeAttrs = (StepFloat =:: Just 1)
:& (MinFloat =:: 0)
:& (MaxFloat =:: 100)
:& RNil
-- | A record representing a widget of the _Box class from IPython
defaultBoxWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> IPythonWidget 'LayoutType -> Rec Attr BoxClass
defaultBoxWidget viewName modelName layout = defaultCoreWidget <+> defaultDOMWidget viewName modelName layout <+> intAttrs
where
intAttrs = (Children =:: [])
:& (BoxStyle =:: DefaultBox)
:& RNil
-- | A record representing a widget of the _SelectionContainer class from IPython
defaultSelectionContainerWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> IPythonWidget 'LayoutType -> Rec Attr SelectionContainerClass
defaultSelectionContainerWidget viewName modelName layout = defaultBoxWidget viewName modelName layout <+> selAttrs
where
selAttrs = (Titles =:: [])
:& (SelectedIndex =:: Nothing)
:& (ChangeHandler =:: return ())
:& RNil
-- | A record representing a widget of the _Media class from IPython
defaultMediaWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> IPythonWidget 'LayoutType -> Rec Attr MediaClass
defaultMediaWidget viewName modelName layout = defaultCoreWidget <+> defaultDOMWidget viewName modelName layout <+> mediaAttrs
where
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)
:& (ViewName =:! "StyleView")
:& (ViewModule =:! "@jupyter-widgets/base")
:& (ViewModuleVersion =:! "1.1.0")
:& (ModelModule =:! "@jupyter-widgets/controls")
:& (ModelModuleVersion =:! "1.4.0")
:& RNil
-- | A record representing a widget of the DescriptionStyle class from IPython
defaultDescriptionStyleWidget :: FieldType 'S.ModelName -> Rec Attr DescriptionStyleClass
defaultDescriptionStyleWidget modelName = defaultStyleWidget modelName <+> dstyle
where
dstyle = (DescriptionWidth =:: "")
:& 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. Doesn't work if the field is read only.
setField :: (f ∈ WidgetFields w, IHaskellWidget (IPythonWidget w), ToPairs (Attr f))
=> IPythonWidget w -> SField f -> FieldType f -> IO ()
setField widget sfield fval = do
attr <- getAttr widget sfield
when (_ro attr) $ error ("The field " ++ show (fromSing sfield) ++ " is read only")
!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 and without checking if is read only. 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
-- | Displays on stdout the properties (and its types) of a given widget
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
-- | Common function for the different trigger events
triggerEvent :: (FieldType f ~ IO (), f ∈ WidgetFields w) => SField f -> IPythonWidget w -> IO ()
triggerEvent sfield w = noStdin . join $ getField w sfield
-- | Called when the value of an attribute is changed on the front-end
triggerChange :: ('S.ChangeHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerChange = triggerEvent ChangeHandler
-- | Called when the button is clicked
triggerClick :: ('S.ClickHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerClick = triggerEvent ClickHandler
-- | Called when a selection is made in a selection widget
triggerSelection :: ('S.SelectionHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerSelection = triggerEvent SelectionHandler
-- | Called when the text is submited in a text widget (or combobox/password)
triggerSubmit :: ('S.SubmitHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerSubmit = triggerEvent SubmitHandler
-- | Called when the widget is displayed on the notebook
triggerDisplay :: ('S.DisplayHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerDisplay = triggerEvent DisplayHandler
-- | Every IHaskellWidget widget has the same IHaskellDisplay instance, for this
-- reason we need to use FlexibleContexts. The display implementation can still
-- be overriden per widget
instance IHaskellWidget (IPythonWidget w) => IHaskellDisplay (IPythonWidget w) where
display b = do
widgetSendView b -- Keeping compatibility with classic notebook
return $ Display [ widgetdisplay $ unpack $ decodeUtf8 $ encode $ object [
"model_id" .= getCommUUID b,
"version_major" .= version_major,
"version_minor" .= version_minor] ]
where
version_major = 2 :: Int
version_minor = 0 :: Int
-- | The date class from IPython
data Date
-- | No date specified. used by default
= NullDate
-- | Date year month day
| Date Integer Integer Integer deriving (Eq,Ord)
defaultDate :: Date
defaultDate = NullDate
instance Show Date where
show NullDate = "NullDate"
show (Date y m d) = printf "%04d-%02d-%02d" y m d
instance ToJSON Date where
toJSON NullDate = object []
toJSON (Date y m d) = object [ "year" .= toJSON y
, "month" .= toJSON (m-1) -- In the frontend months go from 0 to 11
, "date" .= toJSON d
]
instance FromJSON Date where
parseJSON (Object v) = Date
<$> v .: "year"
<*> ((+1) <$> v .: "month")
<*> v .: "date"
parseJSON Null = pure NullDate
parseJSON _ = mzero
-- | Allows you to unlink a jslink
unlink :: ('S.Source ∈ WidgetFields w, 'S.Target ∈ WidgetFields w, IHaskellWidget (IPythonWidget w))
=> IPythonWidget w
-> IO (IPythonWidget w)
unlink w = do
_ <- setField' w Source EmptyWT
_ <- setField' w Target EmptyWT
return w
data OutputMsg = OutputStream StreamType Text | OutputData Display deriving (Show)
instance ToJSON OutputMsg where
toJSON (OutputStream n t) = object [ "output_type" .= str "stream"
, "name" .= toJSON n
, "text" .= toJSON t
]
toJSON (OutputData d) = object [ "output_type" .= str "display_data"
, "data" .= toJSON d
, "metadata" .= object []
]