diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/ihaskell-widgets.cabal b/ihaskell-widgets.cabal --- a/ihaskell-widgets.cabal +++ b/ihaskell-widgets.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.0 +version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: IPython standard widgets for IHaskell. @@ -52,15 +52,19 @@ library -- Modules exported by the library. exposed-modules: IHaskell.Display.Widgets - + IHaskell.Display.Widgets.Interactive + -- Modules included in this library but not exported. other-modules: IHaskell.Display.Widgets.Button IHaskell.Display.Widgets.Box.Box + IHaskell.Display.Widgets.Box.Proxy + IHaskell.Display.Widgets.Box.PlaceProxy IHaskell.Display.Widgets.Box.FlexBox IHaskell.Display.Widgets.Box.SelectionContainer.Accordion IHaskell.Display.Widgets.Box.SelectionContainer.Tab IHaskell.Display.Widgets.Bool.CheckBox IHaskell.Display.Widgets.Bool.ToggleButton + IHaskell.Display.Widgets.Bool.Valid IHaskell.Display.Widgets.Int.IntText IHaskell.Display.Widgets.Int.BoundedInt.BoundedIntText IHaskell.Display.Widgets.Int.BoundedInt.IntProgress @@ -91,10 +95,10 @@ -- other-extensions: -- Other library packages from which modules are imported. - build-depends: aeson >=0.7 && < 0.9 + build-depends: aeson >=0.7 && < 0.10 , base >=4.7 && <4.9 , containers >= 0.5 - , ipython-kernel >= 0.6.1.1 + , ipython-kernel >= 0.6.1.2 , text >= 0.11 , unordered-containers -any , nats -any diff --git a/src/IHaskell/Display/Widgets.hs b/src/IHaskell/Display/Widgets.hs --- a/src/IHaskell/Display/Widgets.hs +++ b/src/IHaskell/Display/Widgets.hs @@ -3,12 +3,15 @@ import IHaskell.Display.Widgets.Button as X import IHaskell.Display.Widgets.Box.Box as X +import IHaskell.Display.Widgets.Box.Proxy as X +import IHaskell.Display.Widgets.Box.PlaceProxy as X import IHaskell.Display.Widgets.Box.FlexBox as X import IHaskell.Display.Widgets.Box.SelectionContainer.Accordion as X import IHaskell.Display.Widgets.Box.SelectionContainer.Tab as X import IHaskell.Display.Widgets.Bool.CheckBox as X import IHaskell.Display.Widgets.Bool.ToggleButton as X +import IHaskell.Display.Widgets.Bool.Valid as X import IHaskell.Display.Widgets.Int.IntText as X import IHaskell.Display.Widgets.Int.BoundedInt.BoundedIntText as X @@ -38,8 +41,7 @@ import IHaskell.Display.Widgets.String.TextArea as X import IHaskell.Display.Widgets.Common as X -import IHaskell.Display.Widgets.Types as X (setField, getField, properties) - -import IHaskell.Display.Widgets.Types as X (triggerDisplay, triggerChange, triggerClick, +import IHaskell.Display.Widgets.Types as X (setField, getField, properties, + triggerDisplay, triggerChange, triggerClick, triggerSelection, triggerSubmit, ChildWidget(..)) diff --git a/src/IHaskell/Display/Widgets/Bool/CheckBox.hs b/src/IHaskell/Display/Widgets/Bool/CheckBox.hs --- a/src/IHaskell/Display/Widgets/Bool/CheckBox.hs +++ b/src/IHaskell/Display/Widgets/Bool/CheckBox.hs @@ -40,11 +40,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Checkbox"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the image widget return widget diff --git a/src/IHaskell/Display/Widgets/Bool/ToggleButton.hs b/src/IHaskell/Display/Widgets/Bool/ToggleButton.hs --- a/src/IHaskell/Display/Widgets/Bool/ToggleButton.hs +++ b/src/IHaskell/Display/Widgets/Bool/ToggleButton.hs @@ -45,11 +45,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.ToggleButton"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the image widget return widget diff --git a/src/IHaskell/Display/Widgets/Bool/Valid.hs b/src/IHaskell/Display/Widgets/Bool/Valid.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Display/Widgets/Bool/Valid.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module IHaskell.Display.Widgets.Bool.Valid ( + -- * The Valid Widget + ValidWidget, + -- * Constructor + mkValidWidget) where + +-- To keep `cabal repl` happy when running from the ihaskell repo +import Prelude + +import Control.Monad (when, join, void) +import Data.Aeson +import Data.HashMap.Strict as HM +import Data.IORef (newIORef) +import Data.Text (Text) +import Data.Vinyl (Rec(..), (<+>)) + +import IHaskell.Display +import IHaskell.Eval.Widgets +import IHaskell.IPython.Message.UUID as U + +import IHaskell.Display.Widgets.Types +import IHaskell.Display.Widgets.Common + +-- | A 'ValidWidget' represents a Valid widget from IPython.html.widgets. +type ValidWidget = IPythonWidget ValidType + +-- | Create a new output widget +mkValidWidget :: IO ValidWidget +mkValidWidget = do + -- Default properties, with a random uuid + uuid <- U.random + + let boolState = defaultBoolWidget "ValidView" + validState = (ReadOutMsg =:: "") :& RNil + widgetState = WidgetState $ boolState <+> validState + + stateIO <- newIORef widgetState + + let widget = IPythonWidget uuid stateIO + + -- Open a comm for this widget, and store it in the kernel state + widgetSendOpen widget $ toJSON widgetState + + -- Return the image widget + return widget + +instance IHaskellDisplay ValidWidget where + display b = do + widgetSendView b + return $ Display [] + +instance IHaskellWidget ValidWidget where + getCommUUID = uuid diff --git a/src/IHaskell/Display/Widgets/Box/Box.hs b/src/IHaskell/Display/Widgets/Box/Box.hs --- a/src/IHaskell/Display/Widgets/Box/Box.hs +++ b/src/IHaskell/Display/Widgets/Box/Box.hs @@ -40,10 +40,9 @@ stateIO <- newIORef widgetState let box = IPythonWidget uuid stateIO - initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Box"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen box initData $ toJSON widgetState + widgetSendOpen box $ toJSON widgetState -- Return the widget return box diff --git a/src/IHaskell/Display/Widgets/Box/FlexBox.hs b/src/IHaskell/Display/Widgets/Box/FlexBox.hs --- a/src/IHaskell/Display/Widgets/Box/FlexBox.hs +++ b/src/IHaskell/Display/Widgets/Box/FlexBox.hs @@ -46,10 +46,9 @@ stateIO <- newIORef widgetState let box = IPythonWidget uuid stateIO - initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.FlexBox"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen box initData $ toJSON widgetState + widgetSendOpen box $ toJSON widgetState -- Return the widget return box diff --git a/src/IHaskell/Display/Widgets/Box/PlaceProxy.hs b/src/IHaskell/Display/Widgets/Box/PlaceProxy.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Display/Widgets/Box/PlaceProxy.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeSynonymInstances #-} + + +module IHaskell.Display.Widgets.Box.PlaceProxy ( + -- * The PlaceProxy widget + PlaceProxy, + -- * Constructor + mkPlaceProxy) where + +-- To keep `cabal repl` happy when running from the ihaskell repo +import Prelude + +import Control.Monad (when, join) +import Data.Aeson +import Data.HashMap.Strict as HM +import Data.IORef (newIORef) +import Data.Text (Text) +import Data.Vinyl (Rec(..), (<+>)) +import Data.Vinyl.Lens (rput) + +import IHaskell.Display +import IHaskell.Eval.Widgets +import IHaskell.IPython.Message.UUID as U + +import IHaskell.Display.Widgets.Types +import IHaskell.Display.Widgets.Common + +-- | A 'Box' represents a Box widget from IPython.html.widgets. +type PlaceProxy = IPythonWidget PlaceProxyType + +-- | Create a new box +mkPlaceProxy :: IO PlaceProxy +mkPlaceProxy = do + -- Default properties, with a random uuid + uuid <- U.random + + let widgetClassState = defaultWidget "PlaceProxyView" + baseState = rput (ModelName =:: "ProxyModel") widgetClassState + proxyState = (Child =:: Nothing) :& (Selector =:: "") :& RNil + widgetState = WidgetState $ baseState <+> proxyState + + stateIO <- newIORef widgetState + + let widget = IPythonWidget uuid stateIO + + -- Open a comm for this widget, and store it in the kernel state + widgetSendOpen widget $ toJSON widgetState + + -- Return the widget + return widget + +instance IHaskellDisplay PlaceProxy where + display b = do + widgetSendView b + return $ Display [] + +instance IHaskellWidget PlaceProxy where + getCommUUID = uuid diff --git a/src/IHaskell/Display/Widgets/Box/Proxy.hs b/src/IHaskell/Display/Widgets/Box/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Display/Widgets/Box/Proxy.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module IHaskell.Display.Widgets.Box.Proxy ( +-- * The Proxy widget +ProxyWidget, + -- * Constructor + mkProxyWidget) where + +-- To keep `cabal repl` happy when running from the ihaskell repo +import Prelude + +import Control.Monad (when, join) +import Data.Aeson +import Data.HashMap.Strict as HM +import Data.IORef (newIORef) +import Data.Text (Text) +import Data.Vinyl (Rec(..), (<+>)) +import Data.Vinyl.Lens (rput) + +import IHaskell.Display +import IHaskell.Eval.Widgets +import IHaskell.IPython.Message.UUID as U + +import IHaskell.Display.Widgets.Types +import IHaskell.Display.Widgets.Common + +-- | A 'Box' represents a Box widget from IPython.html.widgets. +type ProxyWidget = IPythonWidget ProxyType + +-- | Create a new box +mkProxyWidget :: IO ProxyWidget +mkProxyWidget = do + -- Default properties, with a random uuid + uuid <- U.random + + let widgetClassState = defaultWidget "ProxyView" + baseState = rput (ModelName =:: "ProxyModel") widgetClassState + proxyState = (Child =:: Nothing) :& RNil + widgetState = WidgetState $ baseState <+> proxyState + + stateIO <- newIORef widgetState + + let proxy = IPythonWidget uuid stateIO + + -- Open a comm for this widget, and store it in the kernel state + widgetSendOpen proxy $ toJSON widgetState + + -- Return the widget + return proxy + +instance IHaskellDisplay ProxyWidget where + display b = do + widgetSendView b + return $ Display [] + +instance IHaskellWidget ProxyWidget where + getCommUUID = uuid diff --git a/src/IHaskell/Display/Widgets/Box/SelectionContainer/Accordion.hs b/src/IHaskell/Display/Widgets/Box/SelectionContainer/Accordion.hs --- a/src/IHaskell/Display/Widgets/Box/SelectionContainer/Accordion.hs +++ b/src/IHaskell/Display/Widgets/Box/SelectionContainer/Accordion.hs @@ -41,11 +41,9 @@ stateIO <- newIORef widgetState let box = IPythonWidget uuid stateIO - initData = object - ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Accordion"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen box initData $ toJSON widgetState + widgetSendOpen box $ toJSON widgetState -- Return the widget return box diff --git a/src/IHaskell/Display/Widgets/Box/SelectionContainer/Tab.hs b/src/IHaskell/Display/Widgets/Box/SelectionContainer/Tab.hs --- a/src/IHaskell/Display/Widgets/Box/SelectionContainer/Tab.hs +++ b/src/IHaskell/Display/Widgets/Box/SelectionContainer/Tab.hs @@ -41,10 +41,9 @@ stateIO <- newIORef widgetState let box = IPythonWidget uuid stateIO - initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Tab"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen box initData $ toJSON widgetState + widgetSendOpen box $ toJSON widgetState -- Return the widget return box diff --git a/src/IHaskell/Display/Widgets/Button.hs b/src/IHaskell/Display/Widgets/Button.hs --- a/src/IHaskell/Display/Widgets/Button.hs +++ b/src/IHaskell/Display/Widgets/Button.hs @@ -49,10 +49,8 @@ let button = IPythonWidget uuid stateIO - let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Button"] - -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen button initData $ toJSON buttonState + widgetSendOpen button $ toJSON buttonState -- Return the button widget return button diff --git a/src/IHaskell/Display/Widgets/Common.hs b/src/IHaskell/Display/Widgets/Common.hs --- a/src/IHaskell/Display/Widgets/Common.hs +++ b/src/IHaskell/Display/Widgets/Common.hs @@ -4,19 +4,22 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} + module IHaskell.Display.Widgets.Common where -import Data.Aeson -import Data.Aeson.Types (emptyObject) -import Data.Text (pack, Text) +import Data.Aeson +import Data.Aeson.Types (emptyObject) +import Data.Text (pack, Text) -import IHaskell.Display (IHaskellWidget) -import IHaskell.Eval.Widgets (widgetSendClose) +import IHaskell.Display (IHaskellWidget) +import IHaskell.Eval.Widgets (widgetSendClose) import qualified IHaskell.Display.Widgets.Singletons as S pattern ViewModule = S.SViewModule pattern ViewName = S.SViewName +pattern ModelModule = S.SModelModule +pattern ModelName = S.SModelName pattern MsgThrottle = S.SMsgThrottle pattern Version = S.SVersion pattern DisplayHandler = S.SDisplayHandler @@ -86,12 +89,16 @@ pattern Align = S.SAlign pattern Titles = S.STitles pattern SelectedIndex = S.SSelectedIndex +pattern ReadOutMsg = S.SReadOutMsg +pattern Child = S.SChild +pattern Selector = S.SSelector -- | Close a widget's comm closeWidget :: IHaskellWidget w => w -> IO () closeWidget w = widgetSendClose w emptyObject -newtype StrInt = StrInt Integer deriving (Num, Ord, Eq, Enum) +newtype StrInt = StrInt Integer + deriving (Num, Ord, Eq, Enum) instance ToJSON StrInt where toJSON (StrInt x) = toJSON . pack $ show x @@ -205,7 +212,8 @@ toJSON = toJSON . pack . show -- | Options for selection widgets. -data SelectionOptions = OptionLabels [Text] | OptionDict [(Text, Text)] +data SelectionOptions = OptionLabels [Text] + | OptionDict [(Text, Text)] -- | Orientation values. data OrientationValue = HorizontalOrientation diff --git a/src/IHaskell/Display/Widgets/Float/BoundedFloat/BoundedFloatText.hs b/src/IHaskell/Display/Widgets/Float/BoundedFloat/BoundedFloatText.hs --- a/src/IHaskell/Display/Widgets/Float/BoundedFloat/BoundedFloatText.hs +++ b/src/IHaskell/Display/Widgets/Float/BoundedFloat/BoundedFloatText.hs @@ -42,13 +42,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - [ "model_name" .= str "WidgetModel" - , "widget_class" .= str "IPython.BoundedFloatText" - ] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatProgress.hs b/src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatProgress.hs --- a/src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatProgress.hs +++ b/src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatProgress.hs @@ -38,19 +38,17 @@ uuid <- U.random let boundedFloatAttrs = defaultBoundedFloatWidget "ProgressView" - progressAttrs = (BarStyle =:: DefaultBar) :& RNil + progressAttrs = (Orientation =:: HorizontalOrientation) + :& (BarStyle =:: DefaultBar) + :& RNil widgetState = WidgetState $ boundedFloatAttrs <+> progressAttrs stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - [ "model_name" .= str "WidgetModel" - , "widget_class" .= str "IPython.FloatProgress" - ] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatSlider.hs b/src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatSlider.hs --- a/src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatSlider.hs +++ b/src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatSlider.hs @@ -47,11 +47,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.FloatSlider"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Float/BoundedFloatRange/FloatRangeSlider.hs b/src/IHaskell/Display/Widgets/Float/BoundedFloatRange/FloatRangeSlider.hs --- a/src/IHaskell/Display/Widgets/Float/BoundedFloatRange/FloatRangeSlider.hs +++ b/src/IHaskell/Display/Widgets/Float/BoundedFloatRange/FloatRangeSlider.hs @@ -50,13 +50,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - [ "model_name" .= str "WidgetModel" - , "widget_class" .= str "IPython.FloatRangeSlider" - ] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Float/FloatText.hs b/src/IHaskell/Display/Widgets/Float/FloatText.hs --- a/src/IHaskell/Display/Widgets/Float/FloatText.hs +++ b/src/IHaskell/Display/Widgets/Float/FloatText.hs @@ -41,11 +41,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.FloatText"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Image.hs b/src/IHaskell/Display/Widgets/Image.hs --- a/src/IHaskell/Display/Widgets/Image.hs +++ b/src/IHaskell/Display/Widgets/Image.hs @@ -38,6 +38,8 @@ let dom = defaultDOMWidget "ImageView" img = (ImageFormat =:: PNG) + :& (Width =:+ 0) + :& (Height =:+ 0) :& (B64Value =:: mempty) :& RNil widgetState = WidgetState (dom <+> img) @@ -46,10 +48,8 @@ let widget = IPythonWidget uuid stateIO - let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Image"] - -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the image widget return widget diff --git a/src/IHaskell/Display/Widgets/Int/BoundedInt/BoundedIntText.hs b/src/IHaskell/Display/Widgets/Int/BoundedInt/BoundedIntText.hs --- a/src/IHaskell/Display/Widgets/Int/BoundedInt/BoundedIntText.hs +++ b/src/IHaskell/Display/Widgets/Int/BoundedInt/BoundedIntText.hs @@ -41,13 +41,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - [ "model_name" .= str "WidgetModel" - , "widget_class" .= str "IPython.BoundedIntText" - ] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Int/BoundedInt/IntProgress.hs b/src/IHaskell/Display/Widgets/Int/BoundedInt/IntProgress.hs --- a/src/IHaskell/Display/Widgets/Int/BoundedInt/IntProgress.hs +++ b/src/IHaskell/Display/Widgets/Int/BoundedInt/IntProgress.hs @@ -38,17 +38,17 @@ uuid <- U.random let boundedIntAttrs = defaultBoundedIntWidget "ProgressView" - progressAttrs = (BarStyle =:: DefaultBar) :& RNil + progressAttrs = (Orientation =:: HorizontalOrientation) + :& (BarStyle =:: DefaultBar) + :& RNil widgetState = WidgetState $ boundedIntAttrs <+> progressAttrs stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.IntProgress"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Int/BoundedInt/IntSlider.hs b/src/IHaskell/Display/Widgets/Int/BoundedInt/IntSlider.hs --- a/src/IHaskell/Display/Widgets/Int/BoundedInt/IntSlider.hs +++ b/src/IHaskell/Display/Widgets/Int/BoundedInt/IntSlider.hs @@ -47,11 +47,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.IntSlider"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Int/BoundedIntRange/IntRangeSlider.hs b/src/IHaskell/Display/Widgets/Int/BoundedIntRange/IntRangeSlider.hs --- a/src/IHaskell/Display/Widgets/Int/BoundedIntRange/IntRangeSlider.hs +++ b/src/IHaskell/Display/Widgets/Int/BoundedIntRange/IntRangeSlider.hs @@ -48,13 +48,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - [ "model_name" .= str "WidgetModel" - , "widget_class" .= str "IPython.IntRangeSlider" - ] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Int/IntText.hs b/src/IHaskell/Display/Widgets/Int/IntText.hs --- a/src/IHaskell/Display/Widgets/Int/IntText.hs +++ b/src/IHaskell/Display/Widgets/Int/IntText.hs @@ -41,10 +41,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.IntText"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Interactive.hs b/src/IHaskell/Display/Widgets/Interactive.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Display/Widgets/Interactive.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} + +module IHaskell.Display.Widgets.Interactive (interactive, uncurryHList, Rec(..), Argument(..)) where + +import Data.Text +import Data.Proxy + +import Data.Vinyl.Core +import Data.Vinyl.Functor (Identity(..), Const(..)) +import Data.Vinyl.Derived (HList) +import Data.Vinyl.Lens (type (∈)) +import Data.Vinyl.TypeLevel (RecAll) + +import IHaskell.Display + +import IHaskell.Display.Widgets.Types +import IHaskell.Display.Widgets.Common +import qualified IHaskell.Display.Widgets.Singletons as S (SField(..), Field(..)) + +import IHaskell.Display.Widgets.Box.FlexBox +import IHaskell.Display.Widgets.Bool.CheckBox +import IHaskell.Display.Widgets.String.Text +import IHaskell.Display.Widgets.Int.BoundedInt.IntSlider +import IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider +import IHaskell.Display.Widgets.Output + + +data WidgetConf a where + WidgetConf :: + (RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs, + FromWidget a) => + WrappedWidget (SuitableWidget a) (SuitableHandler a) + (SuitableField a) + a + -> WidgetConf a + +newtype WrappedConstructor a = + WrappedConstructor + { wrappedConstructor :: IO (IPythonWidget (SuitableWidget a)) } + + +type family WithTypes (ts :: [*]) (r :: *) :: * where + WithTypes '[] r = r + WithTypes (x ': xs) r = (x -> WithTypes xs r) + +uncurryHList :: WithTypes ts r -> HList ts -> r +uncurryHList f RNil = f +uncurryHList f (Identity x :& xs) = uncurryHList (f x) xs + +-- Consistent type variables are required to make things play nicely with vinyl + +data Constructor a where + Constructor :: + RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs => + IO (IPythonWidget (SuitableWidget a)) -> Constructor a + +newtype Getter a = Getter (IPythonWidget (SuitableWidget a) -> IO a) + +newtype EventSetter a = EventSetter (IPythonWidget (SuitableWidget a) -> IO () -> IO ()) + +newtype Initializer a = Initializer (IPythonWidget (SuitableWidget a) -> Argument a -> IO ()) + +newtype Trigger a = Trigger (IPythonWidget (SuitableWidget a) -> IO ()) + + +data RequiredWidget a where + RequiredWidget :: + RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs => + IPythonWidget (SuitableWidget a) -> RequiredWidget a + +-- Zipping vinyl records in various ways +applyGetters :: Rec Getter ts -> Rec RequiredWidget ts -> IO (HList ts) +applyGetters RNil RNil = return RNil +applyGetters (Getter getter :& gs) (RequiredWidget widget :& ws) = do + val <- getter widget + rest <- applyGetters gs ws + return $ Identity val :& rest + +applyEventSetters :: Rec EventSetter ts -> Rec RequiredWidget ts -> IO () -> IO () +applyEventSetters RNil RNil _ = return () +applyEventSetters (EventSetter setter :& xs) (RequiredWidget widget :& ws) handler = do + setter widget handler + applyEventSetters xs ws handler + +setInitialValues :: Rec Initializer ts -> Rec RequiredWidget ts -> Rec Argument ts -> IO () +setInitialValues RNil RNil RNil = return () +setInitialValues (Initializer initializer :& fs) (RequiredWidget widget :& ws) (argument :& vs) = do + initializer widget argument + setInitialValues fs ws vs + +extractConstructor :: WidgetConf x -> Constructor x +extractConstructor (WidgetConf wr) = Constructor $ construct wr + +extractGetter :: WidgetConf x -> Getter x +extractGetter (WidgetConf wr) = Getter $ getValue wr + +extractEventSetter :: WidgetConf x -> EventSetter x +extractEventSetter (WidgetConf wr) = EventSetter $ setEvent wr + +extractTrigger :: WidgetConf x -> Trigger x +extractTrigger (WidgetConf wr) = Trigger $ trigger wr + +extractInitializer :: WidgetConf x -> Initializer x +extractInitializer (WidgetConf wr) = Initializer initializer + +createWidget :: Constructor a -> IO (RequiredWidget a) +createWidget (Constructor con) = fmap RequiredWidget con + +mkChildren :: Rec RequiredWidget a -> [ChildWidget] +mkChildren widgets = + let childRecord = rmap (\(RequiredWidget w) -> Const (ChildWidget w)) widgets + in recordToList childRecord + +class MakeConfs (ts :: [*]) where + mkConfs :: proxy ts -> Rec WidgetConf ts + +instance MakeConfs '[] where + mkConfs _ = RNil + +instance (FromWidget t, MakeConfs ts) => MakeConfs (t ': ts) where + mkConfs _ = WidgetConf wrapped :& mkConfs (Proxy :: Proxy ts) + +interactive :: (IHaskellDisplay r, MakeConfs ts) + => (HList ts -> r) -> Rec Argument ts -> IO FlexBox +interactive func = + let confs = mkConfs Proxy + in liftToWidgets func confs + +-- | Transform a function (HList ts -> r) to one which: 1) Uses widgets to accept the arguments 2) +-- Accepts initial values for the arguments 3) Creates a compound FlexBox widget with an embedded +-- OutputWidget for display +liftToWidgets :: IHaskellDisplay r + => (HList ts -> r) -> Rec WidgetConf ts -> Rec Argument ts -> IO FlexBox +liftToWidgets func rc initvals = do + let constructors = rmap extractConstructor rc + getters = rmap extractGetter rc + eventSetters = rmap extractEventSetter rc + initializers = rmap extractInitializer rc + triggers = rmap extractTrigger rc + + bx <- mkFlexBox + out <- mkOutputWidget + + -- Create a list of widgets + widgets <- rtraverse createWidget constructors + + let handler = do + vals <- applyGetters getters widgets + replaceOutput out $ func vals + + -- Apply handler to all widgets + applyEventSetters eventSetters widgets handler + + -- Set initial values for all widgets + setInitialValues initializers widgets initvals + -- applyValueSetters valueSetters widgets $ getList defvals + setField out Width 500 + setField bx Orientation VerticalOrientation + + -- Set children for the FlexBox + let children = mkChildren widgets + setField bx Children $ children ++ [ChildWidget out] + + return bx + + +data WrappedWidget w h f a where + WrappedWidget :: + (FieldType h ~ IO (), FieldType f ~ a, h ∈ WidgetFields w, + f ∈ WidgetFields w, ToPairs (Attr h), + IHaskellWidget (IPythonWidget w), ToPairs (Attr f)) => + IO (IPythonWidget w) -> + S.SField h -> S.SField f -> WrappedWidget w h f a + +construct :: WrappedWidget w h f a -> IO (IPythonWidget w) +construct (WrappedWidget cons _ _) = cons + +getValue :: WrappedWidget w h f a -> IPythonWidget w -> IO a +getValue (WrappedWidget _ _ field) widget = getField widget field + +setValue :: WrappedWidget w h f a -> IPythonWidget w -> a -> IO () +setValue (WrappedWidget _ _ field) widget = setField widget field + +setEvent :: WrappedWidget w h f a -> IPythonWidget w -> IO () -> IO () +setEvent (WrappedWidget _ h _) widget = setField widget h + +trigger :: WrappedWidget w h f a -> IPythonWidget w -> IO () +trigger (WrappedWidget _ h _) = triggerEvent h + +class RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs => FromWidget a where + type SuitableWidget a :: WidgetType + type SuitableHandler a :: S.Field + type SuitableField a :: S.Field + data Argument a + initializer :: IPythonWidget (SuitableWidget a) -> Argument a -> IO () + wrapped :: WrappedWidget (SuitableWidget a) (SuitableHandler a) (SuitableField a) a + +instance FromWidget Bool where + type SuitableWidget Bool = CheckBoxType + type SuitableHandler Bool = S.ChangeHandler + type SuitableField Bool = S.BoolValue + data Argument Bool = BoolVal Bool + initializer w (BoolVal b) = setField w BoolValue b + wrapped = WrappedWidget mkCheckBox ChangeHandler BoolValue + +instance FromWidget Text where + type SuitableWidget Text = TextType + type SuitableHandler Text = S.SubmitHandler + type SuitableField Text = S.StringValue + data Argument Text = TextVal Text + initializer w (TextVal txt) = setField w StringValue txt + wrapped = WrappedWidget mkTextWidget SubmitHandler StringValue + +instance FromWidget Integer where + type SuitableWidget Integer = IntSliderType + type SuitableHandler Integer = S.ChangeHandler + type SuitableField Integer = S.IntValue + data Argument Integer = IntVal Integer + | IntRange (Integer, Integer, Integer) + wrapped = WrappedWidget mkIntSlider ChangeHandler IntValue + initializer w (IntVal int) = setField w IntValue int + initializer w (IntRange (v, l, u)) = do + setField w IntValue v + setField w MinInt l + setField w MaxInt u + +instance FromWidget Double where + type SuitableWidget Double = FloatSliderType + type SuitableHandler Double = S.ChangeHandler + type SuitableField Double = S.FloatValue + data Argument Double = FloatVal Double + | FloatRange (Double, Double, Double) + wrapped = WrappedWidget mkFloatSlider ChangeHandler FloatValue + initializer w (FloatVal d) = setField w FloatValue d + initializer w (FloatRange (v, l, u)) = do + setField w FloatValue v + setField w MinFloat l + setField w MaxFloat u diff --git a/src/IHaskell/Display/Widgets/Output.hs b/src/IHaskell/Display/Widgets/Output.hs --- a/src/IHaskell/Display/Widgets/Output.hs +++ b/src/IHaskell/Display/Widgets/Output.hs @@ -45,10 +45,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object ["model_name" .= str "WidgetModel"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the image widget return widget diff --git a/src/IHaskell/Display/Widgets/Selection/Dropdown.hs b/src/IHaskell/Display/Widgets/Selection/Dropdown.hs --- a/src/IHaskell/Display/Widgets/Selection/Dropdown.hs +++ b/src/IHaskell/Display/Widgets/Selection/Dropdown.hs @@ -41,11 +41,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Dropdown"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Selection/RadioButtons.hs b/src/IHaskell/Display/Widgets/Selection/RadioButtons.hs --- a/src/IHaskell/Display/Widgets/Selection/RadioButtons.hs +++ b/src/IHaskell/Display/Widgets/Selection/RadioButtons.hs @@ -39,11 +39,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.RadioButtons"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Selection/Select.hs b/src/IHaskell/Display/Widgets/Selection/Select.hs --- a/src/IHaskell/Display/Widgets/Selection/Select.hs +++ b/src/IHaskell/Display/Widgets/Selection/Select.hs @@ -39,10 +39,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Select"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Selection/SelectMultiple.hs b/src/IHaskell/Display/Widgets/Selection/SelectMultiple.hs --- a/src/IHaskell/Display/Widgets/Selection/SelectMultiple.hs +++ b/src/IHaskell/Display/Widgets/Selection/SelectMultiple.hs @@ -40,13 +40,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - [ "model_name" .= str "WidgetModel" - , "widget_class" .= str "IPython.SelectMultiple" - ] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Selection/ToggleButtons.hs b/src/IHaskell/Display/Widgets/Selection/ToggleButtons.hs --- a/src/IHaskell/Display/Widgets/Selection/ToggleButtons.hs +++ b/src/IHaskell/Display/Widgets/Selection/ToggleButtons.hs @@ -44,13 +44,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - [ "model_name" .= str "WidgetModel" - , "widget_class" .= str "IPython.ToggleButtons" - ] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Singletons.hs b/src/IHaskell/Display/Widgets/Singletons.hs --- a/src/IHaskell/Display/Widgets/Singletons.hs +++ b/src/IHaskell/Display/Widgets/Singletons.hs @@ -5,14 +5,19 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} + module IHaskell.Display.Widgets.Singletons where -import Data.Singletons.TH +import Data.Singletons.TH -- Widget properties -singletons [d| +singletons + [d| + data Field = ViewModule | ViewName + | ModelModule + | ModelName | MsgThrottle | Version | DisplayHandler @@ -82,5 +87,8 @@ | Align | Titles | SelectedIndex + | ReadOutMsg + | Child + | Selector deriving (Eq, Ord, Show) - |] + |] diff --git a/src/IHaskell/Display/Widgets/String/HTML.hs b/src/IHaskell/Display/Widgets/String/HTML.hs --- a/src/IHaskell/Display/Widgets/String/HTML.hs +++ b/src/IHaskell/Display/Widgets/String/HTML.hs @@ -37,10 +37,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.HTML"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/String/Latex.hs b/src/IHaskell/Display/Widgets/String/Latex.hs --- a/src/IHaskell/Display/Widgets/String/Latex.hs +++ b/src/IHaskell/Display/Widgets/String/Latex.hs @@ -37,10 +37,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Latex"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/String/Text.hs b/src/IHaskell/Display/Widgets/String/Text.hs --- a/src/IHaskell/Display/Widgets/String/Text.hs +++ b/src/IHaskell/Display/Widgets/String/Text.hs @@ -41,10 +41,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Text"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/String/TextArea.hs b/src/IHaskell/Display/Widgets/String/TextArea.hs --- a/src/IHaskell/Display/Widgets/String/TextArea.hs +++ b/src/IHaskell/Display/Widgets/String/TextArea.hs @@ -41,11 +41,9 @@ stateIO <- newIORef widgetState let widget = IPythonWidget uuid stateIO - initData = object - ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Textarea"] -- Open a comm for this widget, and store it in the kernel state - widgetSendOpen widget initData $ toJSON widgetState + widgetSendOpen widget $ toJSON widgetState -- Return the widget return widget diff --git a/src/IHaskell/Display/Widgets/Types.hs b/src/IHaskell/Display/Widgets/Types.hs --- a/src/IHaskell/Display/Widgets/Types.hs +++ b/src/IHaskell/Display/Widgets/Types.hs @@ -12,14 +12,16 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} + module IHaskell.Display.Widgets.Types where -- | 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. +-- 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. +-- 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'. -- @@ -29,157 +31,181 @@ -- 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. +-- 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. +-- 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 need to be sent as Strings (@StrInt@). +-- 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 need to be sent as Strings +-- (@StrInt@). -- -- Child widgets are expected to be sent as strings of the form "IPY_MODEL_", where @@ -- 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. +-- 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 also be found in the messaging +-- Widgets are not able to do console input, the reason for that can be found in the messaging -- specification -import Control.Monad (unless, join, when, void, mapM_) -import Control.Applicative ((<$>)) +import Control.Monad (unless, join, when, void, mapM_) +import Control.Applicative ((<$>)) import qualified Control.Exception as Ex -import GHC.IO.Exception -import System.IO.Error -import System.Posix.IO +import GHC.IO.Exception +import System.IO.Error +import System.Posix.IO -import Data.Aeson -import Data.Aeson.Types (Pair) -import Data.IORef (IORef, readIORef, modifyIORef) -import Data.Text (Text, pack) +import Data.Aeson +import Data.Aeson.Types (Pair) +import Data.IORef (IORef, readIORef, modifyIORef) +import Data.Text (Text, pack) -import Data.Vinyl (Rec (..), (<+>), recordToList, reifyConstraint, rmap, Dict (..)) -import Data.Vinyl.Functor (Compose (..), Const (..)) -import Data.Vinyl.Lens (rget, rput, type (∈)) -import Data.Vinyl.TypeLevel (RecAll) +import Data.Vinyl (Rec(..), (<+>), recordToList, reifyConstraint, rmap, Dict(..)) +import Data.Vinyl.Functor (Compose(..), Const(..)) +import Data.Vinyl.Lens (rget, rput, type (∈)) +import Data.Vinyl.TypeLevel (RecAll) -import Data.Singletons.Prelude ((:++)) -import Data.Singletons.TH +import Data.Singletons.Prelude ((:++)) +import Data.Singletons.TH -import IHaskell.Eval.Widgets (widgetSendUpdate) -import IHaskell.Display (Base64, IHaskellWidget (..)) -import IHaskell.IPython.Message.UUID +import IHaskell.Eval.Widgets (widgetSendUpdate) +import IHaskell.Display (Base64, IHaskellWidget(..)) +import IHaskell.IPython.Message.UUID -import IHaskell.Display.Widgets.Singletons (Field, SField (..)) +import IHaskell.Display.Widgets.Singletons (Field, SField(..)) import qualified IHaskell.Display.Widgets.Singletons as S -import IHaskell.Display.Widgets.Common +import IHaskell.Display.Widgets.Common -- Classes from IPython's widget hierarchy. Defined as such to reduce code duplication. -type WidgetClass = '[ S.ViewModule, S.ViewName, 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 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.SelectedLabels, S.SelectedValues, S.Disabled, S.Description, S.SelectionHandler] + +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.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 = StrInt - FieldType S.Height = StrInt - FieldType S.Padding = StrInt - FieldType S.Margin = StrInt - FieldType S.Color = Text - FieldType S.BackgroundColor = Text - FieldType S.BorderColor = Text - FieldType S.BorderWidth = StrInt - FieldType S.BorderRadius = StrInt - FieldType S.BorderStyle = BorderStyleValue - FieldType S.FontStyle = FontStyleValue - FieldType S.FontWeight = FontWeightValue - FieldType S.FontSize = StrInt - 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.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 = StrInt + FieldType S.Height = StrInt + FieldType S.Padding = StrInt + FieldType S.Margin = StrInt + FieldType S.Color = Text + FieldType S.BackgroundColor = Text + FieldType S.BorderColor = Text + FieldType S.BorderWidth = StrInt + FieldType S.BorderRadius = StrInt + FieldType S.BorderStyle = BorderStyleValue + FieldType S.FontStyle = FontStyleValue + FieldType S.FontWeight = FontWeightValue + FieldType S.FontSize = StrInt + 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) @@ -196,14 +222,14 @@ -- Set according to what IPython widgets use instance CustomBounded StrInt where upperBound = 10 ^ 16 - 1 - lowerBound = - (10 ^ 16 - 1) + lowerBound = -(10 ^ 16 - 1) instance CustomBounded Integer where - lowerBound = - (10 ^ 16 - 1) + lowerBound = -(10 ^ 16 - 1) upperBound = 10 ^ 16 - 1 instance CustomBounded Double where - lowerBound = - (10 ** 16 - 1) + lowerBound = -(10 ** 16 - 1) upperBound = 10 ** 16 - 1 -- Different types of widgets. Every widget in IPython has a corresponding WidgetType @@ -216,6 +242,7 @@ | TextAreaType | CheckBoxType | ToggleButtonType + | ValidType | DropdownType | RadioButtonsType | SelectType @@ -232,43 +259,68 @@ | FloatProgressType | FloatRangeSliderType | BoxType + | ProxyType + | PlaceProxyType | FlexBoxType | 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.B64Value] - WidgetFields OutputType = DOMWidgetClass - WidgetFields HTMLType = StringClass - WidgetFields LatexType = StringClass - WidgetFields TextType = StringClass :++ '[S.SubmitHandler, S.ChangeHandler] - WidgetFields TextAreaType = StringClass :++ '[S.ChangeHandler] - WidgetFields CheckBoxType = BoolClass - WidgetFields ToggleButtonType = BoolClass :++ '[S.Tooltip, S.Icon, S.ButtonStyle] - 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.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.BarStyle] - WidgetFields FloatRangeSliderType = BoundedFloatRangeClass :++ '[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor] - WidgetFields BoxType = BoxClass - WidgetFields FlexBoxType = BoxClass :++ '[S.Orientation, S.Flex, S.Pack, S.Align] - WidgetFields AccordionType = SelectionContainerClass - WidgetFields TabType = SelectionContainerClass + 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 LatexType = StringClass + WidgetFields TextType = + StringClass :++ '[S.SubmitHandler, S.ChangeHandler] + 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 ProxyType = WidgetClass :++ '[S.Child] + WidgetFields PlaceProxyType = WidgetFields ProxyType :++ '[S.Selector] + WidgetFields FlexBoxType = + BoxClass :++ '[S.Orientation, S.Flex, S.Pack, S.Align] + 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 +data AttrVal a = Dummy a + | Real a unwrap :: AttrVal a -> a unwrap (Dummy x) = x @@ -276,98 +328,257 @@ -- Wrapper around a field. data Attr (f :: Field) = - Attr { _value :: AttrVal (FieldType f) - , _verify :: FieldType f -> IO (FieldType f) - , _field :: 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 + 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.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.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] + 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 => Sing f -> FieldType f -> Attr f @@ -380,6 +591,7 @@ | 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)) @@ -390,166 +602,190 @@ -- 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) +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 +-- | 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 S.ViewName -> Rec Attr WidgetClass defaultWidget viewName = (ViewModule =:: "") - :& (ViewName =:: viewName) - :& (MsgThrottle =:+ 3) - :& (Version =:: 0) - :& (DisplayHandler =:: return ()) - :& RNil + :& (ViewName =:: viewName) + :& (ModelModule =:: "") + :& (ModelName =:: "WidgetModel") + :& (MsgThrottle =:+ 3) + :& (Version =:: 0) + :& (DisplayHandler =:: return ()) + :& RNil -- | A record representing an object of the DOMWidget class from IPython defaultDOMWidget :: FieldType S.ViewName -> Rec Attr DOMWidgetClass defaultDOMWidget viewName = defaultWidget viewName <+> 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 + 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 -> Rec Attr StringClass defaultStringWidget viewName = defaultDOMWidget viewName <+> strAttrs - where strAttrs = (StringValue =:: "") - :& (Disabled =:: False) - :& (Description =:: "") - :& (Placeholder =:: "") - :& RNil + where + strAttrs = (StringValue =:: "") + :& (Disabled =:: False) + :& (Description =:: "") + :& (Placeholder =:: "") + :& RNil -- | A record representing a widget of the _Bool class from IPython defaultBoolWidget :: FieldType S.ViewName -> Rec Attr BoolClass defaultBoolWidget viewName = defaultDOMWidget viewName <+> boolAttrs - where boolAttrs = (BoolValue =:: False) - :& (Disabled =:: False) - :& (Description =:: "") - :& (ChangeHandler =:: return ()) - :& RNil + 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 -> Rec Attr SelectionClass defaultSelectionWidget viewName = defaultDOMWidget viewName <+> selectionAttrs - where selectionAttrs = (Options =:: OptionLabels []) - :& (SelectedValue =:: "") - :& (SelectedLabel =:: "") - :& (Disabled =:: False) - :& (Description =:: "") - :& (SelectionHandler =:: return ()) - :& RNil + 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 -> Rec Attr MultipleSelectionClass defaultMultipleSelectionWidget viewName = defaultDOMWidget viewName <+> mulSelAttrs - where mulSelAttrs = (Options =:: OptionLabels []) - :& (SelectedLabels =:: []) - :& (SelectedValues =:: []) - :& (Disabled =:: False) - :& (Description =:: "") - :& (SelectionHandler =:: return ()) - :& RNil + 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 -> Rec Attr IntClass defaultIntWidget viewName = defaultDOMWidget viewName <+> intAttrs - where intAttrs = (IntValue =:: 0) - :& (Disabled =:: False) - :& (Description =:: "") - :& (ChangeHandler =:: return ()) - :& RNil + 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 -> Rec Attr BoundedIntClass defaultBoundedIntWidget viewName = defaultIntWidget viewName <+> boundedIntAttrs - where boundedIntAttrs = (StepInt =:: 1) - :& (MinInt =:: 0) - :& (MaxInt =:: 100) - :& RNil + where + boundedIntAttrs = (StepInt =:: 1) + :& (MinInt =:: 0) + :& (MaxInt =:: 100) + :& RNil -- | A record representing a widget of the _BoundedInt class from IPython defaultIntRangeWidget :: FieldType S.ViewName -> Rec Attr IntRangeClass defaultIntRangeWidget viewName = defaultIntWidget viewName <+> rangeAttrs - where rangeAttrs = (IntPairValue =:: (25, 75)) - :& (LowerInt =:: 0) - :& (UpperInt =:: 100) - :& RNil + 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 -> Rec Attr BoundedIntRangeClass defaultBoundedIntRangeWidget viewName = defaultIntRangeWidget viewName <+> boundedIntRangeAttrs - where boundedIntRangeAttrs = (StepInt =:+ 1) - :& (MinInt =:: 0) - :& (MaxInt =:: 100) - :& RNil + where + boundedIntRangeAttrs = (StepInt =:+ 1) + :& (MinInt =:: 0) + :& (MaxInt =:: 100) + :& RNil -- | A record representing a widget of the _Float class from IPython defaultFloatWidget :: FieldType S.ViewName -> Rec Attr FloatClass defaultFloatWidget viewName = defaultDOMWidget viewName <+> intAttrs - where intAttrs = (FloatValue =:: 0) - :& (Disabled =:: False) - :& (Description =:: "") - :& (ChangeHandler =:: return ()) - :& RNil + 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 -> Rec Attr BoundedFloatClass defaultBoundedFloatWidget viewName = defaultFloatWidget viewName <+> boundedFloatAttrs - where boundedFloatAttrs = (StepFloat =:+ 1) - :& (MinFloat =:: 0) - :& (MaxFloat =:: 100) - :& RNil + where + boundedFloatAttrs = (StepFloat =:+ 1) + :& (MinFloat =:: 0) + :& (MaxFloat =:: 100) + :& RNil -- | A record representing a widget of the _BoundedFloat class from IPython defaultFloatRangeWidget :: FieldType S.ViewName -> Rec Attr FloatRangeClass defaultFloatRangeWidget viewName = defaultFloatWidget viewName <+> rangeAttrs - where rangeAttrs = (FloatPairValue =:: (25, 75)) - :& (LowerFloat =:: 0) - :& (UpperFloat =:: 100) - :& RNil + 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 -> Rec Attr BoundedFloatRangeClass defaultBoundedFloatRangeWidget viewName = defaultFloatRangeWidget viewName <+> boundedFloatRangeAttrs - where boundedFloatRangeAttrs = (StepFloat =:+ 1) - :& (MinFloat =:: 0) - :& (MaxFloat =:: 100) - :& RNil + where + boundedFloatRangeAttrs = (StepFloat =:+ 1) + :& (MinFloat =:: 0) + :& (MaxFloat =:: 100) + :& RNil -- | A record representing a widget of the _Box class from IPython defaultBoxWidget :: FieldType S.ViewName -> Rec Attr BoxClass -defaultBoxWidget viewName = defaultDOMWidget viewName <+> boxAttrs - where boxAttrs = (Children =:: []) - :& (OverflowX =:: DefaultOverflow) - :& (OverflowY =:: DefaultOverflow) - :& (BoxStyle =:: DefaultBox) - :& RNil +defaultBoxWidget viewName = domAttrs <+> boxAttrs + where + defaultDOM = defaultDOMWidget viewName + domAttrs = rput (ModelName =:: "BoxModel") defaultDOM + boxAttrs = (Children =:: []) + :& (OverflowX =:: DefaultOverflow) + :& (OverflowY =:: DefaultOverflow) + :& (BoxStyle =:: DefaultBox) + :& RNil -- | A record representing a widget of the _SelectionContainer class from IPython defaultSelectionContainerWidget :: FieldType S.ViewName -> Rec Attr SelectionContainerClass defaultSelectionContainerWidget viewName = defaultBoxWidget viewName <+> selAttrs - where selAttrs = (Titles =:: []) - :& (SelectedIndex =:: 0) - :& (ChangeHandler =:: return ()) - :& RNil + where + selAttrs = (Titles =:: []) + :& (SelectedIndex =:: 0) + :& (ChangeHandler =:: return ()) + :& RNil newtype WidgetState w = WidgetState { _getState :: Rec Attr (WidgetFields w) } @@ -558,11 +794,15 @@ toJSON record = object . concat - . recordToList - . rmap (\(Compose (Dict x)) -> Const $ toPairs x) - $ reifyConstraint (Proxy :: Proxy ToPairs) $ _getState record + . 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) } +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))