packages feed

ihaskell-widgets 0.2.3.2 → 0.2.3.3

raw patch · 33 files changed

+857/−779 lines, 33 filesdep −natsdep ~basedep ~singletons

Dependencies removed: nats

Dependency ranges changed: base, singletons

Files

ihaskell-widgets.cabal view
@@ -1,22 +1,22 @@--- Initial ihaskell-widgets.cabal generated by cabal init.  For +-- Initial ihaskell-widgets.cabal generated by cabal init.  For -- further documentation, see http://haskell.org/cabal/users-guide/  -- The name of the package. name:                ihaskell-widgets --- The package version.  See the Haskell package versioning policy (PVP) +-- The package version.  See the Haskell package versioning policy (PVP) -- for standards guiding when and how versions should be incremented. -- http://www.haskell.org/haskellwiki/Package_versioning_policy -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.2.3.2+version:             0.2.3.3  -- A short (one-line) description of the package. synopsis:            IPython standard widgets for IHaskell.  -- A longer description of the package.--- description:         +-- description:  -- URL for the project homepage or repository. homepage:            http://www.github.com/gibiansky/IHaskell@@ -30,19 +30,19 @@ -- The package author(s). author:              Sumit Sahrawat --- An email address to which users can send suggestions, bug reports, and +-- An email address to which users can send suggestions, bug reports, and -- patches. maintainer:          Sumit Sahrawat <sumit.sahrawat.apm13@iitbhu.ac.in>,                      Andrew Gibiansky <andrew.gibiansky@gmail.com>  -- A copyright notice.--- copyright:           +-- copyright: --- category:            +-- category:  build-type:          Simple --- Extra files to be distributed with the package, such as examples or a +-- Extra files to be distributed with the package, such as examples or a -- README. extra-source-files:  README.md, MsgSpec.md @@ -50,6 +50,11 @@ cabal-version:       >=1.10  library+  ghc-options:         -Wall++  if impl (ghc >= 8.4)+    ghc-options:       -Wpartial-fields+   -- Modules exported by the library.   exposed-modules:     IHaskell.Display.Widgets                        IHaskell.Display.Widgets.Interactive@@ -89,12 +94,10 @@                        IHaskell.Display.Widgets.Singletons    -- LANGUAGE extensions used by modules in this package.-  -- other-extensions:    -  -  -- Other library packages from which modules are imported.-  -- singletons 2.* require ghc 7.10.2+  -- other-extensions:+   build-depends:       aeson >=0.7-                     , base >=4.7 && <5+                     , base >=4.9 && <5                      , containers >= 0.5                      , ipython-kernel >= 0.6.1.2                      , text >= 0.11@@ -104,30 +107,13 @@                      , scientific -any                      , unix -any                      , ihaskell >= 0.6.4.1-  if impl(ghc >= 7.10.2)-    build-depends:       singletons >= 0.9.0-  if impl(ghc == 7.10.1)-    build-depends:       singletons >= 0.9.0 && <2.0-                       , nats -any-  if impl(ghc < 7.10.1)-    build-depends:       singletons >= 0.9.0 && <2.0-                       , nats <1.1-  ++					 -- The singletons package version is locked to the compiler+					 -- so let cabal choose the right one.+                     , singletons -any+   -- Directories containing source files.   hs-source-dirs:      src-  +   -- Base language which the package is written in.   default-language:    Haskell2010-  -  -- Deal with small -fcontext-stack on ghc-7.8.-  -- Default values:-  --   ghc-7.6.*  = 200-  --   ghc-7.8.*  = 20   -- Too small for vinyl & singletons-  --   ghc-7.10.* = 100-  if impl(ghc == 7.8.*)-    ghc-options:       -fcontext-stack=100--  -- compile without optimizations not to run out of memory on travis-  if impl(ghc == 7.10.*)-    ghc-options:       -O0-
src/IHaskell/Display/Widgets/Bool/CheckBox.hs view
@@ -3,19 +3,21 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Bool.CheckBox (--- * The CheckBox Widget-CheckBox, -          -- * Constructor-          mkCheckBox) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +module IHaskell.Display.Widgets.Bool.CheckBox+  ( -- * The CheckBox Widget+    CheckBox+    -- * Constructor+  , mkCheckBox+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude +import           Control.Monad (void) import           Data.Aeson-import           Data.HashMap.Strict as HM import           Data.IORef (newIORef)-import           Data.Text (Text)  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -25,19 +27,19 @@ import           IHaskell.Display.Widgets.Common  -- | A 'CheckBox' represents a Checkbox widget from IPython.html.widgets.-type CheckBox = IPythonWidget CheckBoxType+type CheckBox = IPythonWidget 'CheckBoxType  -- | Create a new output widget mkCheckBox :: IO CheckBox mkCheckBox = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let widgetState = WidgetState $ defaultBoolWidget "CheckboxView" "CheckboxModel"    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -52,10 +54,9 @@  instance IHaskellWidget CheckBox where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "value" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (Bool value) = HM.lookup key2 dict2-    setField' widget BoolValue value-    triggerChange widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "value"] of+      Just (Bool value) -> do+        void $ setField' widget BoolValue value+        triggerChange widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Bool/ToggleButton.hs view
@@ -3,19 +3,21 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Bool.ToggleButton (--- * The ToggleButton Widget-ToggleButton, -              -- * Constructor-              mkToggleButton) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +module IHaskell.Display.Widgets.Bool.ToggleButton+  ( -- * The ToggleButton Widget+    ToggleButton+    -- * Constructor+  , mkToggleButton+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude +import           Control.Monad (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@@ -26,13 +28,13 @@ import           IHaskell.Display.Widgets.Common  -- | A 'ToggleButton' represents a ToggleButton widget from IPython.html.widgets.-type ToggleButton = IPythonWidget ToggleButtonType+type ToggleButton = IPythonWidget 'ToggleButtonType  -- | Create a new output widget mkToggleButton :: IO ToggleButton mkToggleButton = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let boolState = defaultBoolWidget "ToggleButtonView" "ToggleButtonModel"       toggleState = (Tooltip =:: "")@@ -43,7 +45,7 @@    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -58,10 +60,9 @@  instance IHaskellWidget ToggleButton where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "value" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (Bool value) = HM.lookup key2 dict2-    setField' widget BoolValue value-    triggerChange widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "value"] of+      Just (Bool value) -> do+        void $ setField' widget BoolValue value+        triggerChange widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Bool/Valid.hs view
@@ -3,12 +3,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Bool.Valid (--- * The Valid Widget-ValidWidget, -             -- * Constructor-             mkValidWidget) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +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 @@ -24,13 +27,13 @@ import           IHaskell.Display.Widgets.Common  -- | A 'ValidWidget' represents a Valid widget from IPython.html.widgets.-type ValidWidget = IPythonWidget ValidType+type ValidWidget = IPythonWidget 'ValidType  -- | Create a new output widget mkValidWidget :: IO ValidWidget mkValidWidget = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let boolState = defaultBoolWidget "ValidView" "ValidModel"       validState = (ReadOutMsg =:: "") :& RNil@@ -38,7 +41,7 @@    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState
src/IHaskell/Display/Widgets/Box/Box.hs view
@@ -3,12 +3,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Box.Box (--- * The Box widget-Box, -     -- * Constructor-     mkBox) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +module IHaskell.Display.Widgets.Box.Box+  ( -- * The Box widget+    Box+    -- * Constructor+  , mkBox+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude @@ -22,19 +25,19 @@ import           IHaskell.Display.Widgets.Types  -- | A 'Box' represents a Box widget from IPython.html.widgets.-type Box = IPythonWidget BoxType+type Box = IPythonWidget 'BoxType  -- | Create a new box mkBox :: IO Box mkBox = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let widgetState = WidgetState $ defaultBoxWidget "BoxView" "BoxModel"    stateIO <- newIORef widgetState -  let box = IPythonWidget uuid stateIO+  let box = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen box $ toJSON widgetState
src/IHaskell/Display/Widgets/Box/SelectionContainer/Accordion.hs view
@@ -3,20 +3,22 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Box.SelectionContainer.Accordion (--- * The Accordion widget-Accordion, -           -- * Constructor-           mkAccordion) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +module IHaskell.Display.Widgets.Box.SelectionContainer.Accordion+  ( -- * The Accordion widget+    Accordion+    -- * Constructor+  , mkAccordion+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude +import           Control.Monad (void) import           Data.Aeson-import           Data.HashMap.Strict as HM import           Data.IORef (newIORef) import qualified Data.Scientific as Sci-import           Data.Text (Text)  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -26,19 +28,19 @@ import           IHaskell.Display.Widgets.Common  -- | A 'Accordion' represents a Accordion widget from IPython.html.widgets.-type Accordion = IPythonWidget AccordionType+type Accordion = IPythonWidget 'AccordionType  -- | Create a new box mkAccordion :: IO Accordion mkAccordion = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let widgetState = WidgetState $ defaultSelectionContainerWidget "AccordionView" "AccordionModel"    stateIO <- newIORef widgetState -  let box = IPythonWidget uuid stateIO+  let box = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen box $ toJSON widgetState@@ -53,10 +55,9 @@  instance IHaskellWidget Accordion where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "selected_index" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (Number num) = HM.lookup key2 dict2-    setField' widget SelectedIndex (Sci.coefficient num)-    triggerChange widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "selected_index"] of+      Just (Number num) -> do+        void $ setField' widget SelectedIndex (Sci.coefficient num)+        triggerChange widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Box/SelectionContainer/Tab.hs view
@@ -3,20 +3,21 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Box.SelectionContainer.Tab (--- * The Tab widget-TabWidget, -           -- * Constructor-           mkTabWidget) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +module IHaskell.Display.Widgets.Box.SelectionContainer.Tab+  ( -- * The Tab widget+    TabWidget+    -- * Constructor+  , mkTabWidget+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude  import           Data.Aeson-import           Data.HashMap.Strict as HM import           Data.IORef (newIORef) import qualified Data.Scientific as Sci-import           Data.Text (Text)  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -26,19 +27,19 @@ import           IHaskell.Display.Widgets.Common  -- | A 'TabWidget' represents a Tab widget from IPython.html.widgets.-type TabWidget = IPythonWidget TabType+type TabWidget = IPythonWidget 'TabType  -- | Create a new box mkTabWidget :: IO TabWidget mkTabWidget = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let widgetState = WidgetState $ defaultSelectionContainerWidget "TabView" "TabModel"    stateIO <- newIORef widgetState -  let box = IPythonWidget uuid stateIO+  let box = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen box $ toJSON widgetState@@ -53,10 +54,9 @@  instance IHaskellWidget TabWidget where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "selected_index" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (Number num) = HM.lookup key2 dict2-    setField' widget SelectedIndex (Sci.coefficient num)-    triggerChange widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "selected_index"] of+      Just (Number num) -> do+        _ <- setField' widget SelectedIndex (Sci.coefficient num)+        triggerChange widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Button.hs view
@@ -3,20 +3,20 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Button (--- * The Button Widget-Button, -        -- * Create a new button-        mkButton) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +module IHaskell.Display.Widgets.Button+  ( -- * The Button Widget+    Button+    -- * Create a new button+  , mkButton+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude -import           Control.Monad (when) import           Data.Aeson-import           Data.HashMap.Strict as HM import           Data.IORef (newIORef)-import           Data.Text (Text) import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display@@ -27,13 +27,13 @@ import           IHaskell.Display.Widgets.Common  -- | A 'Button' represents a Button from IPython.html.widgets.-type Button = IPythonWidget ButtonType+type Button = IPythonWidget 'ButtonType  -- | Create a new button mkButton :: IO Button mkButton = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let dom = defaultDOMWidget "ButtonView" "ButtonModel"       but = (Description =:: "")@@ -47,7 +47,7 @@    stateIO <- newIORef buttonState -  let button = IPythonWidget uuid stateIO+  let button = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen button $ toJSON buttonState@@ -62,9 +62,7 @@  instance IHaskellWidget Button where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "content" :: Text-        key2 = "event" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (String event) = HM.lookup key2 dict2-    when (event == "click") $ triggerClick widget+  comm widget val _ =+    case nestedObjectLookup val ["content", "event"] of+      Just (String "click") -> triggerClick widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Common.hs view
@@ -7,10 +7,16 @@ {-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DeriveDataTypeable #-} +-- There are lots of pattern synpnyms, and little would be gained by adding+-- the type signatures.+{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+ module IHaskell.Display.Widgets.Common where  import           Data.Aeson import           Data.Aeson.Types (emptyObject)+import           Data.HashMap.Strict as HM import           Data.Text (pack, Text) import           Data.Typeable (Typeable) @@ -268,3 +274,11 @@   toJSON EndLocation = "end"   toJSON BaselineLocation = "baseline"   toJSON StretchLocation = "stretch"++-- Could use 'lens-aeson' here but this is easier to read.+nestedObjectLookup :: Value -> [Text] -> Maybe Value+nestedObjectLookup val [] = Just val+nestedObjectLookup val (x:xs) =+  case val of+    Object o -> maybe Nothing (`nestedObjectLookup` xs) $ HM.lookup x o+    _ -> Nothing
src/IHaskell/Display/Widgets/Float/BoundedFloat/BoundedFloatText.hs view
@@ -3,21 +3,22 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText (--- * The BoundedFloatText--- Widget-BoundedFloatText, -                  -- * Constructor-                  mkBoundedFloatText) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +module IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText+  ( -- * The BoundedFloatText Widget+    BoundedFloatText+    -- * Constructor+  , mkBoundedFloatText+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude +import           Control.Monad (void) import           Data.Aeson-import qualified Data.HashMap.Strict as HM import           Data.IORef (newIORef) import qualified Data.Scientific as Sci-import           Data.Text (Text)  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -27,19 +28,19 @@ import           IHaskell.Display.Widgets.Common  -- | 'BoundedFloatText' represents an BoundedFloatText widget from IPython.html.widgets.-type BoundedFloatText = IPythonWidget BoundedFloatTextType+type BoundedFloatText = IPythonWidget 'BoundedFloatTextType  -- | Create a new widget mkBoundedFloatText :: IO BoundedFloatText mkBoundedFloatText = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let widgetState = WidgetState $ defaultBoundedFloatWidget "FloatTextView" "FloatTextModel"    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -54,10 +55,9 @@  instance IHaskellWidget BoundedFloatText where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "value" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (Number value) = HM.lookup key2 dict2-    setField' widget FloatValue (Sci.toRealFloat value)-    triggerChange widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "value"] of+      Just (Number value) -> do+        void $ setField' widget FloatValue (Sci.toRealFloat value)+        triggerChange widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatProgress.hs view
@@ -3,12 +3,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Float.BoundedFloat.FloatProgress (--- * The FloatProgress Widget-FloatProgress, -               -- * Constructor-               mkFloatProgress) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +module IHaskell.Display.Widgets.Float.BoundedFloat.FloatProgress+  ( -- * The FloatProgress Widget+    FloatProgress+    -- * Constructor+  , mkFloatProgress+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude @@ -24,13 +27,13 @@ import           IHaskell.Display.Widgets.Common  -- | 'FloatProgress' represents an FloatProgress widget from IPython.html.widgets.-type FloatProgress = IPythonWidget FloatProgressType+type FloatProgress = IPythonWidget 'FloatProgressType  -- | Create a new widget mkFloatProgress :: IO FloatProgress mkFloatProgress = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let boundedFloatAttrs = defaultBoundedFloatWidget "ProgressView" "ProgressModel"       progressAttrs = (Orientation =:: HorizontalOrientation)@@ -40,7 +43,7 @@    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState
src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatSlider.hs view
@@ -3,20 +3,22 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider (--- * The FloatSlider Widget-FloatSlider, -             -- * Constructor-             mkFloatSlider) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +module IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider+  ( -- * The FloatSlider Widget+    FloatSlider+    -- * Constructor+  , mkFloatSlider+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude +import           Control.Monad (void) import           Data.Aeson-import qualified Data.HashMap.Strict as HM import           Data.IORef (newIORef) import qualified Data.Scientific as Sci-import           Data.Text (Text) import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display@@ -27,13 +29,13 @@ import           IHaskell.Display.Widgets.Common  -- | 'FloatSlider' represents an FloatSlider widget from IPython.html.widgets.-type FloatSlider = IPythonWidget FloatSliderType+type FloatSlider = IPythonWidget 'FloatSliderType  -- | Create a new widget mkFloatSlider :: IO FloatSlider mkFloatSlider = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let boundedFloatAttrs = defaultBoundedFloatWidget "FloatSliderView" "FloatSliderModel"       sliderAttrs = (Orientation =:: HorizontalOrientation)@@ -45,7 +47,7 @@    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -60,10 +62,9 @@  instance IHaskellWidget FloatSlider where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "value" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (Number value) = HM.lookup key2 dict2-    setField' widget FloatValue (Sci.toRealFloat value)-    triggerChange widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "value"] of+      Just (Number value) -> do+        void $ setField' widget FloatValue (Sci.toRealFloat value)+        triggerChange widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Float/BoundedFloatRange/FloatRangeSlider.hs view
@@ -3,21 +3,22 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider (--- * The FloatRangeSlider--- Widget-FloatRangeSlider, -                  -- * Constructor-                  mkFloatRangeSlider) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +module IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider+  ( -- * The FloatRangeSlider Widget+    FloatRangeSlider+    -- * Constructor+  , mkFloatRangeSlider+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude +import           Control.Monad (void) import           Data.Aeson-import qualified Data.HashMap.Strict as HM import           Data.IORef (newIORef) import qualified Data.Scientific as Sci-import           Data.Text (Text) import qualified Data.Vector as V import           Data.Vinyl (Rec(..), (<+>)) @@ -29,13 +30,13 @@ import           IHaskell.Display.Widgets.Common  -- | 'FloatRangeSlider' represents an FloatRangeSlider widget from IPython.html.widgets.-type FloatRangeSlider = IPythonWidget FloatRangeSliderType+type FloatRangeSlider = IPythonWidget 'FloatRangeSliderType  -- | Create a new widget mkFloatRangeSlider :: IO FloatRangeSlider mkFloatRangeSlider = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let boundedFloatAttrs = defaultBoundedFloatRangeWidget "FloatSliderView" "FloatSliderModel"       sliderAttrs = (Orientation =:: HorizontalOrientation)@@ -47,7 +48,7 @@    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -62,11 +63,12 @@  instance IHaskellWidget FloatRangeSlider where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "value" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (Array values) = HM.lookup key2 dict2-        [x, y] = map (\(Number x) -> Sci.toRealFloat x) $ V.toList values-    setField' widget FloatPairValue (x, y)-    triggerChange widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "value"] of+      Just (Array values) ->+        case map (\(Number x) -> Sci.toRealFloat x) $ V.toList values of+          [x, y] -> do+            void $ setField' widget FloatPairValue (x, y)+            triggerChange widget+          _ -> pure ()+      _ -> pure ()
src/IHaskell/Display/Widgets/Float/FloatText.hs view
@@ -3,20 +3,22 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Float.FloatText (--- * The FloatText Widget-FloatText, -           -- * Constructor-           mkFloatText) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +module IHaskell.Display.Widgets.Float.FloatText+  ( -- * The FloatText Widget+    FloatText+    -- * Constructor+  , mkFloatText+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude +import           Control.Monad (void) import           Data.Aeson-import qualified Data.HashMap.Strict as HM import           Data.IORef (newIORef) import qualified Data.Scientific as Sci-import           Data.Text (Text)  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -26,19 +28,19 @@ import           IHaskell.Display.Widgets.Common  -- | 'FloatText' represents an FloatText widget from IPython.html.widgets.-type FloatText = IPythonWidget FloatTextType+type FloatText = IPythonWidget 'FloatTextType  -- | Create a new widget mkFloatText :: IO FloatText mkFloatText = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let widgetState = WidgetState $ defaultFloatWidget "FloatTextView" "FloatTextModel"    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -53,10 +55,9 @@  instance IHaskellWidget FloatText where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "value" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (Number value) = HM.lookup key2 dict2-    setField' widget FloatValue (Sci.toRealFloat value)-    triggerChange widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "value"] of+      Just (Number value) -> do+        void $ setField' widget FloatValue (Sci.toRealFloat value)+        triggerChange widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Image.hs view
@@ -3,12 +3,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Image (--- * The Image Widget-ImageWidget, -             -- * Constructor-             mkImageWidget) where+{-# OPTIONS_GHC -fno-warn-orphans #-} +module IHaskell.Display.Widgets.Image+  ( -- * The Image Widget+    ImageWidget+    -- * Constructor+  , mkImageWidget+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude @@ -25,13 +28,13 @@ import           IHaskell.Display.Widgets.Common  -- | An 'ImageWidget' represents a Image widget from IPython.html.widgets.-type ImageWidget = IPythonWidget ImageType+type ImageWidget = IPythonWidget 'ImageType  -- | Create a new image widget mkImageWidget :: IO ImageWidget mkImageWidget = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let dom = defaultDOMWidget "ImageView" "ImageModel"       img = (ImageFormat =:: PNG)@@ -43,7 +46,7 @@    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState
src/IHaskell/Display/Widgets/Int/BoundedInt/BoundedIntText.hs view
@@ -3,20 +3,22 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Int.BoundedInt.BoundedIntText (--- * The BoundedIntText Widget-BoundedIntText, -                -- * Constructor-                mkBoundedIntText) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +module IHaskell.Display.Widgets.Int.BoundedInt.BoundedIntText+  ( -- * The BoundedIntText Widget+    BoundedIntText+    -- * Constructor+  , mkBoundedIntText+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude +import           Control.Monad (void) import           Data.Aeson-import qualified Data.HashMap.Strict as HM import           Data.IORef (newIORef) import qualified Data.Scientific as Sci-import           Data.Text (Text)  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -26,19 +28,19 @@ import           IHaskell.Display.Widgets.Common  -- | 'BoundedIntText' represents an BoundedIntText widget from IPython.html.widgets.-type BoundedIntText = IPythonWidget BoundedIntTextType+type BoundedIntText = IPythonWidget 'BoundedIntTextType  -- | Create a new widget mkBoundedIntText :: IO BoundedIntText mkBoundedIntText = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let widgetState = WidgetState $ defaultBoundedIntWidget "IntTextView" "IntTextModel"    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -53,10 +55,9 @@  instance IHaskellWidget BoundedIntText where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "value" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (Number value) = HM.lookup key2 dict2-    setField' widget IntValue (Sci.coefficient value)-    triggerChange widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "value"] of+      Just (Number value) -> do+        void $ setField' widget IntValue (Sci.coefficient value)+        triggerChange widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Int/BoundedInt/IntProgress.hs view
@@ -3,12 +3,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Int.BoundedInt.IntProgress (--- * The IntProgress Widget-IntProgress, -             -- * Constructor-             mkIntProgress) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +module IHaskell.Display.Widgets.Int.BoundedInt.IntProgress+  ( -- * The IntProgress Widget+    IntProgress+    -- * Constructor+  , mkIntProgress+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude @@ -24,13 +27,13 @@ import           IHaskell.Display.Widgets.Common  -- | 'IntProgress' represents an IntProgress widget from IPython.html.widgets.-type IntProgress = IPythonWidget IntProgressType+type IntProgress = IPythonWidget 'IntProgressType  -- | Create a new widget mkIntProgress :: IO IntProgress mkIntProgress = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let boundedIntAttrs = defaultBoundedIntWidget "ProgressView" "ProgressModel"       progressAttrs = (Orientation =:: HorizontalOrientation)@@ -40,7 +43,7 @@    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState
src/IHaskell/Display/Widgets/Int/BoundedInt/IntSlider.hs view
@@ -3,20 +3,22 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Int.BoundedInt.IntSlider (--- * The IntSlider Widget-IntSlider, -           -- * Constructor-           mkIntSlider) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +module IHaskell.Display.Widgets.Int.BoundedInt.IntSlider+  ( -- * The IntSlider Widget+    IntSlider+    -- * Constructor+  , mkIntSlider+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude +import           Control.Monad (void) import           Data.Aeson-import qualified Data.HashMap.Strict as HM import           Data.IORef (newIORef) import qualified Data.Scientific as Sci-import           Data.Text (Text) import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display@@ -27,13 +29,13 @@ import           IHaskell.Display.Widgets.Common  -- | 'IntSlider' represents an IntSlider widget from IPython.html.widgets.-type IntSlider = IPythonWidget IntSliderType+type IntSlider = IPythonWidget 'IntSliderType  -- | Create a new widget mkIntSlider :: IO IntSlider mkIntSlider = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let boundedIntAttrs = defaultBoundedIntWidget "IntSliderView" "IntSliderModel"       sliderAttrs = (Orientation =:: HorizontalOrientation)@@ -45,7 +47,7 @@    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -60,10 +62,9 @@  instance IHaskellWidget IntSlider where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "value" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (Number value) = HM.lookup key2 dict2-    setField' widget IntValue (Sci.coefficient value)-    triggerChange widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "value"] of+      Just (Number value) -> do+        void $ setField' widget IntValue (Sci.coefficient value)+        triggerChange widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Int/BoundedIntRange/IntRangeSlider.hs view
@@ -3,20 +3,22 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Int.BoundedIntRange.IntRangeSlider (--- * The IntRangeSlider Widget-IntRangeSlider, -                -- * Constructor-                mkIntRangeSlider) where+{-# OPTIONS_GHC -fno-warn-orphans  #-} +module IHaskell.Display.Widgets.Int.BoundedIntRange.IntRangeSlider+  ( -- * The IntRangeSlider Widget+    IntRangeSlider+    -- * Constructor+  , mkIntRangeSlider+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude +import           Control.Monad (void) import           Data.Aeson-import qualified Data.HashMap.Strict as HM import           Data.IORef (newIORef) import qualified Data.Scientific as Sci-import           Data.Text (Text) import qualified Data.Vector as V import           Data.Vinyl (Rec(..), (<+>)) @@ -28,13 +30,13 @@ import           IHaskell.Display.Widgets.Common  -- | 'IntRangeSlider' represents an IntRangeSlider widget from IPython.html.widgets.-type IntRangeSlider = IPythonWidget IntRangeSliderType+type IntRangeSlider = IPythonWidget 'IntRangeSliderType  -- | Create a new widget mkIntRangeSlider :: IO IntRangeSlider mkIntRangeSlider = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let boundedIntAttrs = defaultBoundedIntRangeWidget "IntSliderView" "IntSliderModel"       sliderAttrs = (Orientation =:: HorizontalOrientation)@@ -46,7 +48,7 @@    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -61,11 +63,12 @@  instance IHaskellWidget IntRangeSlider where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "value" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (Array values) = HM.lookup key2 dict2-        [x, y] = map (\(Number x) -> Sci.coefficient x) $ V.toList values-    setField' widget IntPairValue (x, y)-    triggerChange widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "value"] of+      Just (Array values) ->+        case map (\(Number x) -> Sci.coefficient x) $ V.toList values of+          [x, y] -> do+            void $ setField' widget IntPairValue (x, y)+            triggerChange widget+          _ -> pure ()+      _ -> pure ()
src/IHaskell/Display/Widgets/Int/IntText.hs view
@@ -3,20 +3,22 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Int.IntText (--- * The IntText Widget-IntText, -         -- * Constructor-         mkIntText) where+{-# OPTIONS_GHC -fno-warn-orphans #-} +module IHaskell.Display.Widgets.Int.IntText+  ( -- * The IntText Widget+    IntText+    -- * Constructor+  , mkIntText+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude +import           Control.Monad (void) import           Data.Aeson-import qualified Data.HashMap.Strict as HM import           Data.IORef (newIORef) import qualified Data.Scientific as Sci-import           Data.Text (Text)  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -26,19 +28,19 @@ import           IHaskell.Display.Widgets.Common  -- | 'IntText' represents an IntText widget from IPython.html.widgets.-type IntText = IPythonWidget IntTextType+type IntText = IPythonWidget 'IntTextType  -- | Create a new widget mkIntText :: IO IntText mkIntText = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let widgetState = WidgetState $ defaultIntWidget "IntTextView" "IntTextModel"    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -53,10 +55,9 @@  instance IHaskellWidget IntText where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "value" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (Number value) = HM.lookup key2 dict2-    setField' widget IntValue (Sci.coefficient value)-    triggerChange widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "value"] of+      Just (Number value) -> do+        void $ setField' widget IntValue (Sci.coefficient value)+        triggerChange widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Interactive.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-}@@ -8,12 +9,22 @@ {-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE PolyKinds #-} -module IHaskell.Display.Widgets.Interactive (interactive, uncurryHList, Rec(..), Argument(..)) where+module IHaskell.Display.Widgets.Interactive+  ( interactive+  , uncurryHList+  , Rec (..)+  , Argument(..)+  ) where  import           Data.Text import           Data.Proxy -import           Data.Vinyl.Core+#if MIN_VERSION_vinyl(0,9,0)+import           Data.Vinyl.Core (Rec(..))+import           Data.Vinyl.Recursive (recordToList, rmap, rtraverse)+#else+import           Data.Vinyl.Core (Rec(..), recordToList, rmap, rtraverse)+#endif import           Data.Vinyl.Functor (Identity(..), Const(..)) import           Data.Vinyl.Derived (HList) import           Data.Vinyl.Lens (type (∈))@@ -32,7 +43,7 @@ import           IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider import           IHaskell.Display.Widgets.Output - + data WidgetConf a where         WidgetConf ::             (RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs,@@ -42,7 +53,7 @@               a               -> WidgetConf a - + type family WithTypes (ts :: [*]) (r :: *) :: * where         WithTypes '[] r = r         WithTypes (x ': xs) r = (x -> WithTypes xs r)@@ -52,7 +63,7 @@ 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 =>@@ -64,7 +75,7 @@  newtype Initializer a = Initializer (IPythonWidget (SuitableWidget a) -> Argument a -> IO ()) - + data RequiredWidget a where         RequiredWidget ::             RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs =>@@ -86,8 +97,8 @@  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 (Initializer initialize :& fs) (RequiredWidget widget :& ws) (argument :& vs) = do+  initialize widget argument   setInitialValues fs ws vs  extractConstructor :: WidgetConf x -> Constructor x@@ -163,7 +174,7 @@    return bx - + data WrappedWidget w h f a where         WrappedWidget ::             (FieldType h ~ IO (), FieldType f ~ a, h ∈ WidgetFields w,@@ -173,7 +184,7 @@               S.SField h -> S.SField f -> WrappedWidget w h f a  construct :: WrappedWidget w h f a -> IO (IPythonWidget w)-construct (WrappedWidget cons _ _) = cons+construct (WrappedWidget cs _ _) = cs  getValue :: WrappedWidget w h f a -> IPythonWidget w -> IO a getValue (WrappedWidget _ _ field) widget = getField widget field@@ -190,25 +201,25 @@   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+  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+  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+  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@@ -219,9 +230,9 @@     setField w MaxInt u  instance FromWidget Double where-  type SuitableWidget Double = FloatSliderType-  type SuitableHandler Double = S.ChangeHandler-  type SuitableField Double = S.FloatValue+  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
src/IHaskell/Display/Widgets/Output.hs view
@@ -3,17 +3,19 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Output (-    -- * The Output Widget-    OutputWidget,+{-# OPTIONS_GHC -fno-warn-orphans #-}++module IHaskell.Display.Widgets.Output+  ( -- * The Output Widget+    OutputWidget     -- * Constructor-    mkOutputWidget,+  , mkOutputWidget     -- * Using the output widget-    appendOutput,-    clearOutput,-    clearOutput_,-    replaceOutput,-    ) where+  , appendOutput+  , clearOutput+  , clearOutput_+  , replaceOutput+  ) where  -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude@@ -28,19 +30,19 @@ import           IHaskell.Display.Widgets.Types  -- | An 'OutputWidget' represents a Output widget from IPython.html.widgets.-type OutputWidget = IPythonWidget OutputType+type OutputWidget = IPythonWidget 'OutputType  -- | Create a new output widget mkOutputWidget :: IO OutputWidget mkOutputWidget = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random    let widgetState = WidgetState $ defaultDOMWidget "OutputView" "OutputModel"    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState
src/IHaskell/Display/Widgets/Selection/Dropdown.hs view
@@ -3,20 +3,21 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Selection.Dropdown (--- * The Dropdown Widget-Dropdown, -          -- * Constructor-          mkDropdown) where+{-# OPTIONS_GHC -fno-warn-orphans #-} +module IHaskell.Display.Widgets.Selection.Dropdown+  ( -- * The Dropdown Widget+    Dropdown+    -- * Constructor+  , mkDropdown+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude  import           Control.Monad (void) import           Data.Aeson-import qualified Data.HashMap.Strict as HM import           Data.IORef (newIORef)-import           Data.Text (Text) import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display@@ -27,20 +28,20 @@ import           IHaskell.Display.Widgets.Common  -- | A 'Dropdown' represents a Dropdown widget from IPython.html.widgets.-type Dropdown = IPythonWidget DropdownType+type Dropdown = IPythonWidget 'DropdownType  -- | Create a new Dropdown widget mkDropdown :: IO Dropdown mkDropdown = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random   let selectionAttrs = defaultSelectionWidget "DropdownView" "DropdownModel"       dropdownAttrs = (ButtonStyle =:: DefaultButton) :& RNil       widgetState = WidgetState $ selectionAttrs <+> dropdownAttrs    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -55,20 +56,19 @@  instance IHaskellWidget Dropdown where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "selected_label" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (String label) = HM.lookup key2 dict2-    opts <- getField widget Options-    case opts of-      OptionLabels _ -> void $ do-        setField' widget SelectedLabel label-        setField' widget SelectedValue label-      OptionDict ps ->-        case lookup label ps of-          Nothing -> return ()-          Just value -> void $ do-            setField' widget SelectedLabel label-            setField' widget SelectedValue value-    triggerSelection widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "selected_label"] of+      Just (String label) -> do+        opts <- getField widget Options+        case opts of+          OptionLabels _ -> do+            void $ setField' widget SelectedLabel label+            void $ setField' widget SelectedValue label+          OptionDict ps ->+            case lookup label ps of+              Nothing -> return ()+              Just value -> do+                void $ setField' widget SelectedLabel label+                void $ setField' widget SelectedValue value+        triggerSelection widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Selection/RadioButtons.hs view
@@ -3,20 +3,21 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Selection.RadioButtons (--- * The RadioButtons Widget-RadioButtons, -              -- * Constructor-              mkRadioButtons) where+{-# OPTIONS_GHC -fno-warn-orphans #-} +module IHaskell.Display.Widgets.Selection.RadioButtons+  ( -- * The RadioButtons Widget+    RadioButtons+    -- * Constructor+  , mkRadioButtons+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude -import           Control.Monad (when, void)+import           Control.Monad (void) import           Data.Aeson-import qualified Data.HashMap.Strict as HM import           Data.IORef (newIORef)-import           Data.Text (Text)  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -26,18 +27,18 @@ import           IHaskell.Display.Widgets.Common  -- | A 'RadioButtons' represents a RadioButtons widget from IPython.html.widgets.-type RadioButtons = IPythonWidget RadioButtonsType+type RadioButtons = IPythonWidget 'RadioButtonsType  -- | Create a new RadioButtons widget mkRadioButtons :: IO RadioButtons mkRadioButtons = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random   let widgetState = WidgetState $ defaultSelectionWidget "RadioButtonsView" "RadioButtonsModel"    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -52,20 +53,19 @@  instance IHaskellWidget RadioButtons where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "selected_label" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (String label) = HM.lookup key2 dict2-    opts <- getField widget Options-    case opts of-      OptionLabels _ -> void $ do-        setField' widget SelectedLabel label-        setField' widget SelectedValue label-      OptionDict ps ->-        case lookup label ps of-          Nothing -> return ()-          Just value -> void $ do-            setField' widget SelectedLabel label-            setField' widget SelectedValue value-    triggerSelection widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "selected_label"] of+      Just (String label) -> do+        opts <- getField widget Options+        case opts of+          OptionLabels _ -> do+            void $ setField' widget SelectedLabel label+            void $ setField' widget SelectedValue label+          OptionDict ps ->+            case lookup label ps of+              Nothing -> pure ()+              Just value -> do+                void $ setField' widget SelectedLabel label+                void $ setField' widget SelectedValue value+        triggerSelection widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Selection/Select.hs view
@@ -3,21 +3,21 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Selection.Select (--- * The Select Widget-Select, -        -- * Constructor-        mkSelect) where+{-# OPTIONS_GHC -fno-warn-orphans #-} +module IHaskell.Display.Widgets.Selection.Select+  ( -- * The Select Widget+    Select+    -- * Constructor+  , mkSelect+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude -import           Control.Monad (when, join, void)+import           Control.Monad (void) import           Data.Aeson-import qualified Data.HashMap.Strict as HM import           Data.IORef (newIORef)-import           Data.Text (Text)-import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -27,18 +27,18 @@ import           IHaskell.Display.Widgets.Common  -- | A 'Select' represents a Select widget from IPython.html.widgets.-type Select = IPythonWidget SelectType+type Select = IPythonWidget 'SelectType  -- | Create a new Select widget mkSelect :: IO Select mkSelect = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random   let widgetState = WidgetState $ defaultSelectionWidget "SelectView" "SelectModel"    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -53,20 +53,19 @@  instance IHaskellWidget Select where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "selected_label" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (String label) = HM.lookup key2 dict2-    opts <- getField widget Options-    case opts of-      OptionLabels _ -> void $ do-        setField' widget SelectedLabel label-        setField' widget SelectedValue label-      OptionDict ps ->-        case lookup label ps of-          Nothing -> return ()-          Just value -> void $ do-            setField' widget SelectedLabel label-            setField' widget SelectedValue value-    triggerSelection widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "selected_label"] of+      Just (String label) -> do+        opts <- getField widget Options+        case opts of+          OptionLabels _ -> do+            void $ setField' widget SelectedLabel label+            void $ setField' widget SelectedValue label+          OptionDict ps ->+            case lookup label ps of+              Nothing -> pure ()+              Just value -> do+                void $ setField' widget SelectedLabel label+                void $ setField' widget SelectedValue value+        triggerSelection widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Selection/SelectMultiple.hs view
@@ -3,20 +3,21 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Selection.SelectMultiple (--- * The SelectMultiple Widget-SelectMultiple, -                -- * Constructor-                mkSelectMultiple) where+{-# OPTIONS_GHC -fno-warn-orphans #-} +module IHaskell.Display.Widgets.Selection.SelectMultiple+  ( -- * The SelectMultiple Widget+    SelectMultiple+    -- * Constructor+  , mkSelectMultiple+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude  import           Control.Monad (void) import           Data.Aeson-import qualified Data.HashMap.Strict as HM import           Data.IORef (newIORef)-import           Data.Text (Text) import qualified Data.Vector as V  import           IHaskell.Display@@ -27,18 +28,18 @@ import           IHaskell.Display.Widgets.Common  -- | A 'SelectMultiple' represents a SelectMultiple widget from IPython.html.widgets.-type SelectMultiple = IPythonWidget SelectMultipleType+type SelectMultiple = IPythonWidget 'SelectMultipleType  -- | Create a new SelectMultiple widget mkSelectMultiple :: IO SelectMultiple mkSelectMultiple = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random   let widgetState = WidgetState $ defaultMultipleSelectionWidget "SelectMultipleView" "SelectMultipleModel"    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -53,21 +54,20 @@  instance IHaskellWidget SelectMultiple where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "selected_labels" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (Array labels) = HM.lookup key2 dict2-        labelList = map (\(String x) -> x) $ V.toList labels-    opts <- getField widget Options-    case opts of-      OptionLabels _ -> void $ do-        setField' widget SelectedLabels labelList-        setField' widget SelectedValues labelList-      OptionDict ps ->-        case sequence $ map (`lookup` ps) labelList of-          Nothing -> return ()-          Just valueList -> void $ do-            setField' widget SelectedLabels labelList-            setField' widget SelectedValues valueList-    triggerSelection widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "selected_labels"] of+      Just (Array labels) -> do+        let labelList = map (\(String x) -> x) $ V.toList labels+        opts <- getField widget Options+        case opts of+          OptionLabels _ -> do+            void $ setField' widget SelectedLabels labelList+            void $ setField' widget SelectedValues labelList+          OptionDict ps ->+            case mapM (`lookup` ps) labelList of+              Nothing -> pure ()+              Just valueList -> do+                void $ setField' widget SelectedLabels labelList+                void $ setField' widget SelectedValues valueList+        triggerSelection widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Selection/ToggleButtons.hs view
@@ -3,20 +3,21 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.Selection.ToggleButtons (--- * The ToggleButtons Widget-ToggleButtons, -               -- * Constructor-               mkToggleButtons) where+{-# OPTIONS_GHC -fno-warn-orphans #-} +module IHaskell.Display.Widgets.Selection.ToggleButtons+  ( -- * The ToggleButtons Widget+    ToggleButtons+    -- * Constructor+  , mkToggleButtons+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude  import           Control.Monad (void) import           Data.Aeson-import qualified Data.HashMap.Strict as HM import           Data.IORef (newIORef)-import           Data.Text (Text) import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display@@ -27,13 +28,13 @@ import           IHaskell.Display.Widgets.Common  -- | A 'ToggleButtons' represents a ToggleButtons widget from IPython.html.widgets.-type ToggleButtons = IPythonWidget ToggleButtonsType+type ToggleButtons = IPythonWidget 'ToggleButtonsType  -- | Create a new ToggleButtons widget mkToggleButtons :: IO ToggleButtons mkToggleButtons = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random   let selectionAttrs = defaultSelectionWidget "ToggleButtonsView" "ToggleButtonsModel"       toggleButtonsAttrs = (Tooltips =:: [])                            :& (Icons =:: [])@@ -43,7 +44,7 @@    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -58,20 +59,19 @@  instance IHaskellWidget ToggleButtons where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "selected_label" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (String label) = HM.lookup key2 dict2-    opts <- getField widget Options-    case opts of-      OptionLabels _ -> void $ do-        setField' widget SelectedLabel label-        setField' widget SelectedValue label-      OptionDict ps ->-        case lookup label ps of-          Nothing -> return ()-          Just value -> void $ do-            setField' widget SelectedLabel label-            setField' widget SelectedValue value-    triggerSelection widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "selected_label"]  of+      Just (String label) -> do+        opts <- getField widget Options+        case opts of+          OptionLabels _ -> void $ do+            void $ setField' widget SelectedLabel label+            void $ setField' widget SelectedValue label+          OptionDict ps ->+            case lookup label ps of+              Nothing -> pure ()+              Just value -> do+                void $ setField' widget SelectedLabel label+                void $ setField' widget SelectedValue value+        triggerSelection widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Singletons.hs view
@@ -6,17 +6,24 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE CPP #-}  module IHaskell.Display.Widgets.Singletons where  import           Data.Singletons.TH++#if MIN_VERSION_singletons(2,4,0)+#else import           Data.Singletons.Prelude.Ord+#endif  -- Widget properties singletons   [d|-   +   data Field = ViewModule              | ViewName              | ModelModule
src/IHaskell/Display/Widgets/String/HTML.hs view
@@ -3,12 +3,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.String.HTML (--- * The HTML Widget-HTMLWidget, -            -- * Constructor-            mkHTMLWidget) where+{-# OPTIONS_GHC -fno-warn-orphans #-} +module IHaskell.Display.Widgets.String.HTML+  ( -- * The HTML Widget+    HTMLWidget+    -- * Constructor+  , mkHTMLWidget+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude @@ -22,18 +25,18 @@ import           IHaskell.Display.Widgets.Types  -- | A 'HTMLWidget' represents a HTML widget from IPython.html.widgets.-type HTMLWidget = IPythonWidget HTMLType+type HTMLWidget = IPythonWidget 'HTMLType  -- | Create a new HTML widget mkHTMLWidget :: IO HTMLWidget mkHTMLWidget = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random   let widgetState = WidgetState $ defaultStringWidget "HTMLView" "HTMLModel"    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState
src/IHaskell/Display/Widgets/String/Label.hs view
@@ -3,12 +3,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.String.Label (--- * The Label Widget-LabelWidget, -             -- * Constructor-             mkLabelWidget) where+{-# OPTIONS_GHC -fno-warn-orphans #-} +module IHaskell.Display.Widgets.String.Label+  ( -- * The Label Widget+    LabelWidget+    -- * Constructor+  , mkLabelWidget+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude @@ -22,18 +25,18 @@ import           IHaskell.Display.Widgets.Types  -- | A 'LabelWidget' represents a Label widget from IPython.html.widgets.-type LabelWidget = IPythonWidget LabelType+type LabelWidget = IPythonWidget 'LabelType  -- | Create a new Label widget mkLabelWidget :: IO LabelWidget mkLabelWidget = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random   let widgetState = WidgetState $ defaultStringWidget "LabelView" "LabelModel"    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState
src/IHaskell/Display/Widgets/String/Text.hs view
@@ -3,18 +3,20 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.String.Text (--- * The Text Widget-TextWidget, -            -- * Constructor-            mkTextWidget) where+{-# OPTIONS_GHC -fno-warn-orphans #-} +module IHaskell.Display.Widgets.String.Text+  ( -- * The Text Widget+    TextWidget+    -- * Constructor+  , mkTextWidget+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude  import           Control.Monad (when) import           Data.Aeson-import qualified Data.HashMap.Strict as Map import           Data.IORef (newIORef) import           Data.Vinyl (Rec(..), (<+>)) @@ -26,20 +28,20 @@ import           IHaskell.Display.Widgets.Common  -- | A 'TextWidget' represents a Text widget from IPython.html.widgets.-type TextWidget = IPythonWidget TextType+type TextWidget = IPythonWidget 'TextType  -- | Create a new Text widget mkTextWidget :: IO TextWidget mkTextWidget = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random   let strWidget = defaultStringWidget "TextView" "TextModel"       txtWidget = (SubmitHandler =:: return ()) :& (ChangeHandler =:: return ()) :& RNil       widgetState = WidgetState $ strWidget <+> txtWidget    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -55,16 +57,10 @@ instance IHaskellWidget TextWidget where   getCommUUID = uuid   -- Two possibilities: 1. content -> event -> "submit" 2. sync_data -> value -> <new_value>-  comm tw (Object dict1) _ =-    case Map.lookup "sync_data" dict1 of-      Just (Object dict2) ->-        case Map.lookup "value" dict2 of-          Just (String val) -> setField' tw StringValue val >> triggerChange tw-          Nothing           -> return ()-      Nothing ->-        case Map.lookup "content" dict1 of-          Just (Object dict2) ->-            case Map.lookup "event" dict2 of-              Just (String event) -> when (event == "submit") $ triggerSubmit tw-              Nothing             -> return ()-          Nothing -> return ()+  comm tw val _ = do+    case nestedObjectLookup val ["sync_data", "value"] of+      Just (String value) -> setField' tw StringValue value >> triggerChange tw+      _                 -> pure ()+    case nestedObjectLookup val ["content", "event"] of+      Just (String event) -> when (event == "submit") $ triggerSubmit tw+      _                   -> pure ()
src/IHaskell/Display/Widgets/String/TextArea.hs view
@@ -1,21 +1,22 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeSynonymInstances #-} -module IHaskell.Display.Widgets.String.TextArea (--- * The TextArea Widget-TextArea, -          -- * Constructor-          mkTextArea) where+{-# OPTIONS_GHC -fno-warn-orphans #-} +module IHaskell.Display.Widgets.String.TextArea+  ( -- * The TextArea Widget+    TextArea+    -- * Constructor+  , mkTextArea+  ) where+ -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude +import           Control.Monad (void) import           Data.Aeson-import qualified Data.HashMap.Strict as HM import           Data.IORef (newIORef)-import           Data.Text (Text) import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display@@ -26,20 +27,20 @@ import           IHaskell.Display.Widgets.Common  -- | A 'TextArea' represents a Textarea widget from IPython.html.widgets.-type TextArea = IPythonWidget TextAreaType+type TextArea = IPythonWidget 'TextAreaType  -- | Create a new TextArea widget mkTextArea :: IO TextArea mkTextArea = do   -- Default properties, with a random uuid-  uuid <- U.random+  wid <- U.random   let strAttrs = defaultStringWidget "TextareaView" "TextareaModel"       wgtAttrs = (ChangeHandler =:: return ()) :& RNil       widgetState = WidgetState $ strAttrs <+> wgtAttrs    stateIO <- newIORef widgetState -  let widget = IPythonWidget uuid stateIO+  let widget = IPythonWidget wid stateIO    -- Open a comm for this widget, and store it in the kernel state   widgetSendOpen widget $ toJSON widgetState@@ -54,10 +55,9 @@  instance IHaskellWidget TextArea where   getCommUUID = uuid-  comm widget (Object dict1) _ = do-    let key1 = "sync_data" :: Text-        key2 = "value" :: Text-        Just (Object dict2) = HM.lookup key1 dict1-        Just (String value) = HM.lookup key2 dict2-    setField' widget StringValue value-    triggerChange widget+  comm widget val _ =+    case nestedObjectLookup val ["sync_data", "value"] of+      Just (String value) -> do+        void $ setField' widget StringValue value+        triggerChange widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Types.hs view
@@ -14,6 +14,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE CPP #-}  -- | This module houses all the type-trickery needed to make widgets happen. --@@ -71,15 +72,25 @@ import           System.Posix.IO import           Text.Printf (printf) -import           Data.Aeson+import           Data.Aeson hiding (pairs) import           Data.Aeson.Types (Pair)-+import           Data.Int (Int16)+#if MIN_VERSION_vinyl(0,9,0)+import           Data.Vinyl (Rec(..), Dict(..))+import           Data.Vinyl.Recursive ((<+>), recordToList, reifyConstraint, rmap)+#else import           Data.Vinyl (Rec(..), (<+>), recordToList, reifyConstraint, rmap, Dict(..))+#endif import           Data.Vinyl.Functor (Compose(..), Const(..)) import           Data.Vinyl.Lens (rget, rput, type (∈)) import           Data.Vinyl.TypeLevel (RecAll) +#if MIN_VERSION_singletons(2,4,0)+import           Data.Singletons.Prelude.List+#else import           Data.Singletons.Prelude ((:++))+#endif+ import           Data.Singletons.TH  import           GHC.IO.Exception@@ -92,124 +103,134 @@ import qualified IHaskell.Display.Widgets.Singletons as S import           IHaskell.Display.Widgets.Common +#if MIN_VERSION_singletons(2,4,0)+-- Versions of the "singletons" package are tightly tied to the GHC version.+-- Singletons versions 2.3.* and earlier used the type level operator ':++'+-- for appending type level lists while 2.4.* and latter use the normal value+-- level list append operator '++'.+-- To maintain compatibility across GHC versions we keep using the ':++'+-- operator for now.+type (a :++ b) = a ++ b+#endif+ -- Classes from IPython's widget hierarchy. Defined as such to reduce code duplication.-type WidgetClass = '[S.ViewModule, S.ViewName, S.ModelModule, S.ModelName,-  S.MsgThrottle, S.Version, S.DisplayHandler]+type 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 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 StringClass = DOMWidgetClass :++ ['S.StringValue, 'S.Disabled, 'S.Description, 'S.Placeholder] -type BoolClass = DOMWidgetClass :++ '[S.BoolValue, S.Disabled, S.Description, S.ChangeHandler]+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 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 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 IntClass = DOMWidgetClass :++ ['S.IntValue, 'S.Disabled, 'S.Description, 'S.ChangeHandler] -type BoundedIntClass = IntClass :++ '[S.StepInt, S.MinInt, S.MaxInt]+type BoundedIntClass = IntClass :++ ['S.StepInt, 'S.MinInt, 'S.MaxInt] -type IntRangeClass = IntClass :++ '[S.IntPairValue, S.LowerInt, S.UpperInt]+type IntRangeClass = IntClass :++ ['S.IntPairValue, 'S.LowerInt, 'S.UpperInt] -type BoundedIntRangeClass = IntRangeClass :++ '[S.StepInt, S.MinInt, S.MaxInt]+type BoundedIntRangeClass = IntRangeClass :++ ['S.StepInt, 'S.MinInt, 'S.MaxInt] -type FloatClass = DOMWidgetClass :++ '[S.FloatValue, S.Disabled, S.Description, S.ChangeHandler]+type FloatClass = DOMWidgetClass :++ ['S.FloatValue, 'S.Disabled, 'S.Description, 'S.ChangeHandler] -type BoundedFloatClass = FloatClass :++ '[S.StepFloat, S.MinFloat, S.MaxFloat]+type BoundedFloatClass = FloatClass :++ ['S.StepFloat, 'S.MinFloat, 'S.MaxFloat] -type FloatRangeClass = FloatClass :++ '[S.FloatPairValue, S.LowerFloat, S.UpperFloat]+type FloatRangeClass = FloatClass :++ ['S.FloatPairValue, 'S.LowerFloat, 'S.UpperFloat] -type BoundedFloatRangeClass = FloatRangeClass :++ '[S.StepFloat, S.MinFloat, S.MaxFloat]+type BoundedFloatRangeClass = FloatRangeClass :++ ['S.StepFloat, 'S.MinFloat, 'S.MaxFloat] -type BoxClass = DOMWidgetClass :++ '[S.Children, S.OverflowX, S.OverflowY, S.BoxStyle]+type BoxClass = DOMWidgetClass :++ ['S.Children, 'S.OverflowX, 'S.OverflowY, 'S.BoxStyle] -type SelectionContainerClass = BoxClass :++ '[S.Titles, S.SelectedIndex, S.ChangeHandler]+type SelectionContainerClass = BoxClass :++ ['S.Titles, 'S.SelectedIndex, 'S.ChangeHandler]  -- Types associated with Fields.  type family FieldType (f :: Field) :: * where-        FieldType S.ViewModule = Text-        FieldType S.ViewName = Text-        FieldType S.ModelModule = Text-        FieldType S.ModelName = Text-        FieldType S.MsgThrottle = Integer-        FieldType S.Version = Integer-        FieldType S.DisplayHandler = IO ()-        FieldType S.Visible = Bool-        FieldType S.CSS = [(Text, Text, Text)]-        FieldType S.DOMClasses = [Text]-        FieldType S.Width = PixCount-        FieldType S.Height = PixCount-        FieldType S.Padding = PixCount-        FieldType S.Margin = PixCount-        FieldType S.Color = Text-        FieldType S.BackgroundColor = Text-        FieldType S.BorderColor = Text-        FieldType S.BorderWidth = PixCount-        FieldType S.BorderRadius = PixCount-        FieldType S.BorderStyle = BorderStyleValue-        FieldType S.FontStyle = FontStyleValue-        FieldType S.FontWeight = FontWeightValue-        FieldType S.FontSize = PixCount-        FieldType S.FontFamily = Text-        FieldType S.Description = Text-        FieldType S.ClickHandler = IO ()-        FieldType S.SubmitHandler = IO ()-        FieldType S.Disabled = Bool-        FieldType S.StringValue = Text-        FieldType S.Placeholder = Text-        FieldType S.Tooltip = Text-        FieldType S.Icon = Text-        FieldType S.ButtonStyle = ButtonStyleValue-        FieldType S.B64Value = Base64-        FieldType S.ImageFormat = ImageFormatValue-        FieldType S.BoolValue = Bool-        FieldType S.Options = SelectionOptions-        FieldType S.SelectedLabel = Text-        FieldType S.SelectedValue = Text-        FieldType S.SelectionHandler = IO ()-        FieldType S.Tooltips = [Text]-        FieldType S.Icons = [Text]-        FieldType S.SelectedLabels = [Text]-        FieldType S.SelectedValues = [Text]-        FieldType S.IntValue = Integer-        FieldType S.StepInt = Integer-        FieldType S.MinInt = Integer-        FieldType S.MaxInt = Integer-        FieldType S.LowerInt = Integer-        FieldType S.UpperInt = Integer-        FieldType S.IntPairValue = (Integer, Integer)-        FieldType S.Orientation = OrientationValue-        FieldType S.ShowRange = Bool-        FieldType S.ReadOut = Bool-        FieldType S.SliderColor = Text-        FieldType S.BarStyle = BarStyleValue-        FieldType S.FloatValue = Double-        FieldType S.StepFloat = Double-        FieldType S.MinFloat = Double-        FieldType S.MaxFloat = Double-        FieldType S.LowerFloat = Double-        FieldType S.UpperFloat = Double-        FieldType S.FloatPairValue = (Double, Double)-        FieldType S.ChangeHandler = IO ()-        FieldType S.Children = [ChildWidget]-        FieldType S.OverflowX = OverflowValue-        FieldType S.OverflowY = OverflowValue-        FieldType S.BoxStyle = BoxStyleValue-        FieldType S.Flex = Int-        FieldType S.Pack = LocationValue-        FieldType S.Align = LocationValue-        FieldType S.Titles = [Text]-        FieldType S.SelectedIndex = Integer-        FieldType S.ReadOutMsg = Text-        FieldType S.Child = Maybe ChildWidget-        FieldType S.Selector = Text+        FieldType 'S.ViewModule = Text+        FieldType 'S.ViewName = Text+        FieldType 'S.ModelModule = Text+        FieldType 'S.ModelName = Text+        FieldType 'S.MsgThrottle = Integer+        FieldType 'S.Version = Integer+        FieldType 'S.DisplayHandler = IO ()+        FieldType 'S.Visible = Bool+        FieldType 'S.CSS = [(Text, Text, Text)]+        FieldType 'S.DOMClasses = [Text]+        FieldType 'S.Width = PixCount+        FieldType 'S.Height = PixCount+        FieldType 'S.Padding = PixCount+        FieldType 'S.Margin = PixCount+        FieldType 'S.Color = Text+        FieldType 'S.BackgroundColor = Text+        FieldType 'S.BorderColor = Text+        FieldType 'S.BorderWidth = PixCount+        FieldType 'S.BorderRadius = PixCount+        FieldType 'S.BorderStyle = BorderStyleValue+        FieldType 'S.FontStyle = FontStyleValue+        FieldType 'S.FontWeight = FontWeightValue+        FieldType 'S.FontSize = PixCount+        FieldType 'S.FontFamily = Text+        FieldType 'S.Description = Text+        FieldType 'S.ClickHandler = IO ()+        FieldType 'S.SubmitHandler = IO ()+        FieldType 'S.Disabled = Bool+        FieldType 'S.StringValue = Text+        FieldType 'S.Placeholder = Text+        FieldType 'S.Tooltip = Text+        FieldType 'S.Icon = Text+        FieldType 'S.ButtonStyle = ButtonStyleValue+        FieldType 'S.B64Value = Base64+        FieldType 'S.ImageFormat = ImageFormatValue+        FieldType 'S.BoolValue = Bool+        FieldType 'S.Options = SelectionOptions+        FieldType 'S.SelectedLabel = Text+        FieldType 'S.SelectedValue = Text+        FieldType 'S.SelectionHandler = IO ()+        FieldType 'S.Tooltips = [Text]+        FieldType 'S.Icons = [Text]+        FieldType 'S.SelectedLabels = [Text]+        FieldType 'S.SelectedValues = [Text]+        FieldType 'S.IntValue = Integer+        FieldType 'S.StepInt = Integer+        FieldType 'S.MinInt = Integer+        FieldType 'S.MaxInt = Integer+        FieldType 'S.LowerInt = Integer+        FieldType 'S.UpperInt = Integer+        FieldType 'S.IntPairValue = (Integer, Integer)+        FieldType 'S.Orientation = OrientationValue+        FieldType 'S.ShowRange = Bool+        FieldType 'S.ReadOut = Bool+        FieldType 'S.SliderColor = Text+        FieldType 'S.BarStyle = BarStyleValue+        FieldType 'S.FloatValue = Double+        FieldType 'S.StepFloat = Double+        FieldType 'S.MinFloat = Double+        FieldType 'S.MaxFloat = Double+        FieldType 'S.LowerFloat = Double+        FieldType 'S.UpperFloat = Double+        FieldType 'S.FloatPairValue = (Double, Double)+        FieldType 'S.ChangeHandler = IO ()+        FieldType 'S.Children = [ChildWidget]+        FieldType 'S.OverflowX = OverflowValue+        FieldType 'S.OverflowY = OverflowValue+        FieldType 'S.BoxStyle = BoxStyleValue+        FieldType 'S.Flex = Int+        FieldType 'S.Pack = LocationValue+        FieldType 'S.Align = LocationValue+        FieldType 'S.Titles = [Text]+        FieldType 'S.SelectedIndex = Integer+        FieldType 'S.ReadOutMsg = Text+        FieldType 'S.Child = Maybe ChildWidget+        FieldType 'S.Selector = Text  -- | Can be used to put different widgets in a list. Useful for dealing with children widgets. data ChildWidget = forall w. RecAll Attr (WidgetFields w) ToPairs => ChildWidget (IPythonWidget w)@@ -225,16 +246,16 @@  -- Set according to what IPython widgets use instance CustomBounded PixCount where-  upperBound = 10 ^ 16 - 1-  lowerBound = -(10 ^ 16 - 1)+  lowerBound = - fromIntegral (maxBound :: Int16)+  upperBound = fromIntegral (maxBound :: Int16)  instance CustomBounded Integer where-  lowerBound = -(10 ^ 16 - 1)-  upperBound = 10 ^ 16 - 1+  lowerBound = - fromIntegral (maxBound :: Int16)+  upperBound = fromIntegral (maxBound :: Int16)  instance CustomBounded Double where-  lowerBound = -(10 ** 16 - 1)-  upperBound = 10 ** 16 - 1+  lowerBound = - fromIntegral (maxBound :: Int16)+  upperBound = fromIntegral (maxBound :: Int16)  -- Different types of widgets. Every widget in IPython has a corresponding WidgetType data WidgetType = ButtonType@@ -269,52 +290,58 @@ -- Fields associated with a widget  type family WidgetFields (w :: WidgetType) :: [Field] where-        WidgetFields ButtonType =-                                DOMWidgetClass :++-                                  '[S.Description, S.Tooltip, S.Disabled, S.Icon, S.ButtonStyle,-                                    S.ClickHandler]-        WidgetFields ImageType =-                               DOMWidgetClass :++ '[S.ImageFormat, S.Width, S.Height, S.B64Value]-        WidgetFields OutputType = DOMWidgetClass-        WidgetFields HTMLType = StringClass-        WidgetFields LabelType = StringClass-        WidgetFields TextType =-                              StringClass :++ '[S.SubmitHandler, S.ChangeHandler]-        WidgetFields TextAreaType = StringClass :++ '[S.ChangeHandler]-        WidgetFields CheckBoxType = BoolClass-        WidgetFields ToggleButtonType =-                                      BoolClass :++ '[S.Tooltip, S.Icon, S.ButtonStyle]-        WidgetFields ValidType = BoolClass :++ '[S.ReadOutMsg]-        WidgetFields DropdownType = SelectionClass :++ '[S.ButtonStyle]-        WidgetFields RadioButtonsType = SelectionClass-        WidgetFields SelectType = SelectionClass-        WidgetFields ToggleButtonsType =-                                       SelectionClass :++ '[S.Tooltips, S.Icons, S.ButtonStyle]-        WidgetFields SelectMultipleType = MultipleSelectionClass-        WidgetFields IntTextType = IntClass-        WidgetFields BoundedIntTextType = BoundedIntClass-        WidgetFields IntSliderType =-                                   BoundedIntClass :++-                                     '[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]-        WidgetFields IntProgressType =-                                     BoundedIntClass :++ '[S.Orientation, S.BarStyle]-        WidgetFields IntRangeSliderType =-                                        BoundedIntRangeClass :++-                                          '[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]-        WidgetFields FloatTextType = FloatClass-        WidgetFields BoundedFloatTextType = BoundedFloatClass-        WidgetFields FloatSliderType =-                                     BoundedFloatClass :++-                                       '[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]-        WidgetFields FloatProgressType =-                                       BoundedFloatClass :++ '[S.Orientation, S.BarStyle]-        WidgetFields FloatRangeSliderType =-                                          BoundedFloatRangeClass :++-                                            '[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]-        WidgetFields BoxType = BoxClass-        WidgetFields AccordionType = SelectionContainerClass-        WidgetFields TabType = SelectionContainerClass+  WidgetFields 'ButtonType =+                  DOMWidgetClass :+++                    ['S.Description, 'S.Tooltip, 'S.Disabled, 'S.Icon, 'S.ButtonStyle+                    ,'S.ClickHandler+                    ]+  WidgetFields 'ImageType =+                  DOMWidgetClass :++ ['S.ImageFormat, 'S.Width, 'S.Height, 'S.B64Value]+  WidgetFields 'OutputType = DOMWidgetClass+  WidgetFields 'HTMLType = StringClass+  WidgetFields 'LabelType = StringClass+  WidgetFields 'TextType =+                  StringClass :++ ['S.SubmitHandler, 'S.ChangeHandler] +  -- Type level lists with a single element need both the list and the+  -- constructor ticked, and a space between the open square bracket and+  -- the first constructor. See https://ghc.haskell.org/trac/ghc/ticket/15601+  WidgetFields 'TextAreaType = StringClass :++ '[ 'S.ChangeHandler]++  WidgetFields 'CheckBoxType = BoolClass+  WidgetFields 'ToggleButtonType =+                  BoolClass :++ ['S.Tooltip, 'S.Icon, 'S.ButtonStyle]+  WidgetFields 'ValidType = BoolClass :++ '[ 'S.ReadOutMsg]+  WidgetFields 'DropdownType = SelectionClass :++ '[ 'S.ButtonStyle]+  WidgetFields 'RadioButtonsType = SelectionClass+  WidgetFields 'SelectType = SelectionClass+  WidgetFields 'ToggleButtonsType =+                  SelectionClass :++ ['S.Tooltips, 'S.Icons, 'S.ButtonStyle]+  WidgetFields 'SelectMultipleType = MultipleSelectionClass+  WidgetFields 'IntTextType = IntClass+  WidgetFields 'BoundedIntTextType = BoundedIntClass+  WidgetFields 'IntSliderType =+                  BoundedIntClass :+++                    ['S.Orientation, 'S.ShowRange, 'S.ReadOut, 'S.SliderColor]+  WidgetFields 'IntProgressType =+                  BoundedIntClass :++ ['S.Orientation, 'S.BarStyle]+  WidgetFields 'IntRangeSliderType =+                  BoundedIntRangeClass :+++                    ['S.Orientation, 'S.ShowRange, 'S.ReadOut, 'S.SliderColor]+  WidgetFields 'FloatTextType = FloatClass+  WidgetFields 'BoundedFloatTextType = BoundedFloatClass+  WidgetFields 'FloatSliderType =+                  BoundedFloatClass :+++                    ['S.Orientation, 'S.ShowRange, 'S.ReadOut, 'S.SliderColor]+  WidgetFields 'FloatProgressType =+                  BoundedFloatClass :++ ['S.Orientation, 'S.BarStyle]+  WidgetFields 'FloatRangeSliderType =+                  BoundedFloatRangeClass :+++                    ['S.Orientation, 'S.ShowRange, 'S.ReadOut, 'S.SliderColor]+  WidgetFields 'BoxType = BoxClass+  WidgetFields 'AccordionType = SelectionContainerClass+  WidgetFields 'TabType = SelectionContainerClass+ -- Wrapper around a field's value. A dummy value is sent as an empty string to the frontend. data AttrVal a = Dummy a                | Real a@@ -345,121 +372,121 @@   toPairs :: a -> [Pair]  -- Attributes that aren't synced with the frontend give [] on toPairs-instance ToPairs (Attr S.ViewModule) where+instance ToPairs (Attr 'S.ViewModule) where   toPairs x = ["_view_module" .= toJSON x] -instance ToPairs (Attr S.ViewName) where+instance ToPairs (Attr 'S.ViewName) where   toPairs x = ["_view_name" .= toJSON x] -instance ToPairs (Attr S.ModelModule) where+instance ToPairs (Attr 'S.ModelModule) where   toPairs x = ["_model_module" .= toJSON x] -instance ToPairs (Attr S.ModelName) where+instance ToPairs (Attr 'S.ModelName) where   toPairs x = ["_model_name" .= toJSON x] -instance ToPairs (Attr S.MsgThrottle) where+instance ToPairs (Attr 'S.MsgThrottle) where   toPairs x = ["msg_throttle" .= toJSON x] -instance ToPairs (Attr S.Version) where+instance ToPairs (Attr 'S.Version) where   toPairs x = ["version" .= toJSON x] -instance ToPairs (Attr S.DisplayHandler) where+instance ToPairs (Attr 'S.DisplayHandler) where   toPairs _ = [] -- Not sent to the frontend -instance ToPairs (Attr S.Visible) where+instance ToPairs (Attr 'S.Visible) where   toPairs x = ["visible" .= toJSON x] -instance ToPairs (Attr S.CSS) where+instance ToPairs (Attr 'S.CSS) where   toPairs x = ["_css" .= toJSON x] -instance ToPairs (Attr S.DOMClasses) where+instance ToPairs (Attr 'S.DOMClasses) where   toPairs x = ["_dom_classes" .= toJSON x] -instance ToPairs (Attr S.Width) where+instance ToPairs (Attr 'S.Width) where   toPairs x = ["width" .= toJSON x] -instance ToPairs (Attr S.Height) where+instance ToPairs (Attr 'S.Height) where   toPairs x = ["height" .= toJSON x] -instance ToPairs (Attr S.Padding) where+instance ToPairs (Attr 'S.Padding) where   toPairs x = ["padding" .= toJSON x] -instance ToPairs (Attr S.Margin) where+instance ToPairs (Attr 'S.Margin) where   toPairs x = ["margin" .= toJSON x] -instance ToPairs (Attr S.Color) where+instance ToPairs (Attr 'S.Color) where   toPairs x = ["color" .= toJSON x] -instance ToPairs (Attr S.BackgroundColor) where+instance ToPairs (Attr 'S.BackgroundColor) where   toPairs x = ["background_color" .= toJSON x] -instance ToPairs (Attr S.BorderColor) where+instance ToPairs (Attr 'S.BorderColor) where   toPairs x = ["border_color" .= toJSON x] -instance ToPairs (Attr S.BorderWidth) where+instance ToPairs (Attr 'S.BorderWidth) where   toPairs x = ["border_width" .= toJSON x] -instance ToPairs (Attr S.BorderRadius) where+instance ToPairs (Attr 'S.BorderRadius) where   toPairs x = ["border_radius" .= toJSON x] -instance ToPairs (Attr S.BorderStyle) where+instance ToPairs (Attr 'S.BorderStyle) where   toPairs x = ["border_style" .= toJSON x] -instance ToPairs (Attr S.FontStyle) where+instance ToPairs (Attr 'S.FontStyle) where   toPairs x = ["font_style" .= toJSON x] -instance ToPairs (Attr S.FontWeight) where+instance ToPairs (Attr 'S.FontWeight) where   toPairs x = ["font_weight" .= toJSON x] -instance ToPairs (Attr S.FontSize) where+instance ToPairs (Attr 'S.FontSize) where   toPairs x = ["font_size" .= toJSON x] -instance ToPairs (Attr S.FontFamily) where+instance ToPairs (Attr 'S.FontFamily) where   toPairs x = ["font_family" .= toJSON x] -instance ToPairs (Attr S.Description) where+instance ToPairs (Attr 'S.Description) where   toPairs x = ["description" .= toJSON x] -instance ToPairs (Attr S.ClickHandler) where+instance ToPairs (Attr 'S.ClickHandler) where   toPairs _ = [] -- Not sent to the frontend -instance ToPairs (Attr S.SubmitHandler) where+instance ToPairs (Attr 'S.SubmitHandler) where   toPairs _ = [] -- Not sent to the frontend -instance ToPairs (Attr S.Disabled) where+instance ToPairs (Attr 'S.Disabled) where   toPairs x = ["disabled" .= toJSON x] -instance ToPairs (Attr S.StringValue) where+instance ToPairs (Attr 'S.StringValue) where   toPairs x = ["value" .= toJSON x] -instance ToPairs (Attr S.Placeholder) where+instance ToPairs (Attr 'S.Placeholder) where   toPairs x = ["placeholder" .= toJSON x] -instance ToPairs (Attr S.Tooltip) where+instance ToPairs (Attr 'S.Tooltip) where   toPairs x = ["tooltip" .= toJSON x] -instance ToPairs (Attr S.Icon) where+instance ToPairs (Attr 'S.Icon) where   toPairs x = ["icon" .= toJSON x] -instance ToPairs (Attr S.ButtonStyle) where+instance ToPairs (Attr 'S.ButtonStyle) where   toPairs x = ["button_style" .= toJSON x] -instance ToPairs (Attr S.B64Value) where+instance ToPairs (Attr 'S.B64Value) where   toPairs x = ["_b64value" .= toJSON x] -instance ToPairs (Attr S.ImageFormat) where+instance ToPairs (Attr 'S.ImageFormat) where   toPairs x = ["format" .= toJSON x] -instance ToPairs (Attr S.BoolValue) where+instance ToPairs (Attr 'S.BoolValue) where   toPairs x = ["value" .= toJSON x] -instance ToPairs (Attr S.SelectedLabel) where+instance ToPairs (Attr 'S.SelectedLabel) where   toPairs x = ["selected_label" .= toJSON x] -instance ToPairs (Attr S.SelectedValue) where+instance ToPairs (Attr 'S.SelectedValue) where   toPairs x = ["value" .= toJSON x] -instance ToPairs (Attr S.Options) where+instance ToPairs (Attr 'S.Options) where   toPairs x =     case _value x of       Dummy _                -> labels ("" :: Text)@@ -468,115 +495,115 @@     where       labels xs = ["_options_labels" .= xs] -instance ToPairs (Attr S.SelectionHandler) where+instance ToPairs (Attr 'S.SelectionHandler) where   toPairs _ = [] -- Not sent to the frontend -instance ToPairs (Attr S.Tooltips) where+instance ToPairs (Attr 'S.Tooltips) where   toPairs x = ["tooltips" .= toJSON x] -instance ToPairs (Attr S.Icons) where+instance ToPairs (Attr 'S.Icons) where   toPairs x = ["icons" .= toJSON x] -instance ToPairs (Attr S.SelectedLabels) where+instance ToPairs (Attr 'S.SelectedLabels) where   toPairs x = ["selected_labels" .= toJSON x] -instance ToPairs (Attr S.SelectedValues) where+instance ToPairs (Attr 'S.SelectedValues) where   toPairs x = ["values" .= toJSON x] -instance ToPairs (Attr S.IntValue) where+instance ToPairs (Attr 'S.IntValue) where   toPairs x = ["value" .= toJSON x] -instance ToPairs (Attr S.StepInt) where+instance ToPairs (Attr 'S.StepInt) where   toPairs x = ["step" .= toJSON x] -instance ToPairs (Attr S.MinInt) where+instance ToPairs (Attr 'S.MinInt) where   toPairs x = ["min" .= toJSON x] -instance ToPairs (Attr S.MaxInt) where+instance ToPairs (Attr 'S.MaxInt) where   toPairs x = ["max" .= toJSON x] -instance ToPairs (Attr S.IntPairValue) where+instance ToPairs (Attr 'S.IntPairValue) where   toPairs x = ["value" .= toJSON x] -instance ToPairs (Attr S.LowerInt) where+instance ToPairs (Attr 'S.LowerInt) where   toPairs x = ["min" .= toJSON x] -instance ToPairs (Attr S.UpperInt) where+instance ToPairs (Attr 'S.UpperInt) where   toPairs x = ["max" .= toJSON x] -instance ToPairs (Attr S.FloatValue) where+instance ToPairs (Attr 'S.FloatValue) where   toPairs x = ["value" .= toJSON x] -instance ToPairs (Attr S.StepFloat) where+instance ToPairs (Attr 'S.StepFloat) where   toPairs x = ["step" .= toJSON x] -instance ToPairs (Attr S.MinFloat) where+instance ToPairs (Attr 'S.MinFloat) where   toPairs x = ["min" .= toJSON x] -instance ToPairs (Attr S.MaxFloat) where+instance ToPairs (Attr 'S.MaxFloat) where   toPairs x = ["max" .= toJSON x] -instance ToPairs (Attr S.FloatPairValue) where+instance ToPairs (Attr 'S.FloatPairValue) where   toPairs x = ["value" .= toJSON x] -instance ToPairs (Attr S.LowerFloat) where+instance ToPairs (Attr 'S.LowerFloat) where   toPairs x = ["min" .= toJSON x] -instance ToPairs (Attr S.UpperFloat) where+instance ToPairs (Attr 'S.UpperFloat) where   toPairs x = ["max" .= toJSON x] -instance ToPairs (Attr S.Orientation) where+instance ToPairs (Attr 'S.Orientation) where   toPairs x = ["orientation" .= toJSON x] -instance ToPairs (Attr S.ShowRange) where+instance ToPairs (Attr 'S.ShowRange) where   toPairs x = ["_range" .= toJSON x] -instance ToPairs (Attr S.ReadOut) where+instance ToPairs (Attr 'S.ReadOut) where   toPairs x = ["readout" .= toJSON x] -instance ToPairs (Attr S.SliderColor) where+instance ToPairs (Attr 'S.SliderColor) where   toPairs x = ["slider_color" .= toJSON x] -instance ToPairs (Attr S.BarStyle) where+instance ToPairs (Attr 'S.BarStyle) where   toPairs x = ["bar_style" .= toJSON x] -instance ToPairs (Attr S.ChangeHandler) where+instance ToPairs (Attr 'S.ChangeHandler) where   toPairs _ = [] -- Not sent to the frontend -instance ToPairs (Attr S.Children) where+instance ToPairs (Attr 'S.Children) where   toPairs x = ["children" .= toJSON x] -instance ToPairs (Attr S.OverflowX) where+instance ToPairs (Attr 'S.OverflowX) where   toPairs x = ["overflow_x" .= toJSON x] -instance ToPairs (Attr S.OverflowY) where+instance ToPairs (Attr 'S.OverflowY) where   toPairs x = ["overflow_y" .= toJSON x] -instance ToPairs (Attr S.BoxStyle) where+instance ToPairs (Attr 'S.BoxStyle) where   toPairs x = ["box_style" .= toJSON x] -instance ToPairs (Attr S.Flex) where+instance ToPairs (Attr 'S.Flex) where   toPairs x = ["flex" .= toJSON x] -instance ToPairs (Attr S.Pack) where+instance ToPairs (Attr 'S.Pack) where   toPairs x = ["pack" .= toJSON x] -instance ToPairs (Attr S.Align) where+instance ToPairs (Attr 'S.Align) where   toPairs x = ["align" .= toJSON x] -instance ToPairs (Attr S.Titles) where+instance ToPairs (Attr 'S.Titles) where   toPairs x = ["_titles" .= toJSON x] -instance ToPairs (Attr S.SelectedIndex) where+instance ToPairs (Attr 'S.SelectedIndex) where   toPairs x = ["selected_index" .= toJSON x] -instance ToPairs (Attr S.ReadOutMsg) where+instance ToPairs (Attr 'S.ReadOutMsg) where   toPairs x = ["readout" .= toJSON x] -instance ToPairs (Attr S.Child) where+instance ToPairs (Attr 'S.Child) where   toPairs x = ["child" .= toJSON x] -instance ToPairs (Attr S.Selector) where+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@@ -615,7 +642,7 @@ reflect = fromSing  -- | A record representing an object of the Widget class from IPython-defaultWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr WidgetClass+defaultWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr WidgetClass defaultWidget viewName modelName = (ViewModule =:: "jupyter-js-widgets")                                    :& (ViewName =:: viewName)                                    :& (ModelModule =:: "jupyter-js-widgets")@@ -626,7 +653,7 @@                                    :& RNil  -- | A record representing an object of the DOMWidget class from IPython-defaultDOMWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr DOMWidgetClass+defaultDOMWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr DOMWidgetClass defaultDOMWidget viewName modelName = defaultWidget viewName modelName <+> domAttrs   where     domAttrs = (Visible =:: True)@@ -649,7 +676,7 @@                :& RNil  -- | A record representing a widget of the _String class from IPython-defaultStringWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr StringClass+defaultStringWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr StringClass defaultStringWidget viewName modelName = defaultDOMWidget viewName modelName <+> strAttrs   where     strAttrs = (StringValue =:: "")@@ -659,7 +686,7 @@                :& RNil  -- | A record representing a widget of the _Bool class from IPython-defaultBoolWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr BoolClass+defaultBoolWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr BoolClass defaultBoolWidget viewName modelName = defaultDOMWidget viewName modelName <+> boolAttrs   where     boolAttrs = (BoolValue =:: False)@@ -669,7 +696,7 @@                 :& RNil  -- | A record representing a widget of the _Selection class from IPython-defaultSelectionWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr SelectionClass+defaultSelectionWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr SelectionClass defaultSelectionWidget viewName modelName = defaultDOMWidget viewName modelName <+> selectionAttrs   where     selectionAttrs = (Options =:: OptionLabels [])@@ -681,7 +708,7 @@                      :& RNil  -- | A record representing a widget of the _MultipleSelection class from IPython-defaultMultipleSelectionWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr MultipleSelectionClass+defaultMultipleSelectionWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr MultipleSelectionClass defaultMultipleSelectionWidget viewName modelName = defaultDOMWidget viewName modelName <+> mulSelAttrs   where     mulSelAttrs = (Options =:: OptionLabels [])@@ -693,7 +720,7 @@                   :& RNil  -- | A record representing a widget of the _Int class from IPython-defaultIntWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr IntClass+defaultIntWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr IntClass defaultIntWidget viewName modelName = defaultDOMWidget viewName modelName <+> intAttrs   where     intAttrs = (IntValue =:: 0)@@ -703,7 +730,7 @@                :& RNil  -- | A record representing a widget of the _BoundedInt class from IPython-defaultBoundedIntWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr BoundedIntClass+defaultBoundedIntWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr BoundedIntClass defaultBoundedIntWidget viewName modelName = defaultIntWidget viewName modelName <+> boundedIntAttrs   where     boundedIntAttrs = (StepInt =:: 1)@@ -712,7 +739,7 @@                       :& RNil  -- | A record representing a widget of the _BoundedInt class from IPython-defaultIntRangeWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr IntRangeClass+defaultIntRangeWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr IntRangeClass defaultIntRangeWidget viewName modelName = defaultIntWidget viewName modelName <+> rangeAttrs   where     rangeAttrs = (IntPairValue =:: (25, 75))@@ -721,7 +748,7 @@                  :& RNil  -- | A record representing a widget of the _BoundedIntRange class from IPython-defaultBoundedIntRangeWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr BoundedIntRangeClass+defaultBoundedIntRangeWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr BoundedIntRangeClass defaultBoundedIntRangeWidget viewName modelName = defaultIntRangeWidget viewName modelName <+> boundedIntRangeAttrs   where     boundedIntRangeAttrs = (StepInt =:+ 1)@@ -730,7 +757,7 @@                            :& RNil  -- | A record representing a widget of the _Float class from IPython-defaultFloatWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr FloatClass+defaultFloatWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr FloatClass defaultFloatWidget viewName modelName = defaultDOMWidget viewName modelName <+> intAttrs   where     intAttrs = (FloatValue =:: 0)@@ -740,7 +767,7 @@                :& RNil  -- | A record representing a widget of the _BoundedFloat class from IPython-defaultBoundedFloatWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr BoundedFloatClass+defaultBoundedFloatWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr BoundedFloatClass defaultBoundedFloatWidget viewName modelName = defaultFloatWidget viewName modelName <+> boundedFloatAttrs   where     boundedFloatAttrs = (StepFloat =:+ 1)@@ -749,7 +776,7 @@                         :& RNil  -- | A record representing a widget of the _BoundedFloat class from IPython-defaultFloatRangeWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr FloatRangeClass+defaultFloatRangeWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr FloatRangeClass defaultFloatRangeWidget viewName modelName = defaultFloatWidget viewName modelName <+> rangeAttrs   where     rangeAttrs = (FloatPairValue =:: (25, 75))@@ -758,7 +785,7 @@                  :& RNil  -- | A record representing a widget of the _BoundedFloatRange class from IPython-defaultBoundedFloatRangeWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr BoundedFloatRangeClass+defaultBoundedFloatRangeWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr BoundedFloatRangeClass defaultBoundedFloatRangeWidget viewName modelName = defaultFloatRangeWidget viewName modelName <+> boundedFloatRangeAttrs   where     boundedFloatRangeAttrs = (StepFloat =:+ 1)@@ -767,7 +794,7 @@                              :& RNil  -- | A record representing a widget of the _Box class from IPython-defaultBoxWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr BoxClass+defaultBoxWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr BoxClass defaultBoxWidget viewName modelName = defaultDOMWidget viewName modelName <+> intAttrs   where     intAttrs = (Children =:: [])@@ -777,7 +804,7 @@                :& RNil  -- | A record representing a widget of the _SelectionContainer class from IPython-defaultSelectionContainerWidget :: FieldType S.ViewName -> FieldType S.ModelName -> Rec Attr SelectionContainerClass+defaultSelectionContainerWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr SelectionContainerClass defaultSelectionContainerWidget viewName modelName = defaultBoxWidget viewName modelName <+> selAttrs   where     selAttrs = (Titles =:: [])@@ -822,7 +849,11 @@  -- | 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)@@ -860,17 +891,17 @@ triggerEvent :: (FieldType f ~ IO (), f ∈ WidgetFields w) => SField f -> IPythonWidget w -> IO () triggerEvent sfield w = noStdin . join $ getField w sfield -triggerChange :: (S.ChangeHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()+triggerChange :: ('S.ChangeHandler ∈ WidgetFields w) => IPythonWidget w -> IO () triggerChange = triggerEvent ChangeHandler -triggerClick :: (S.ClickHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()+triggerClick :: ('S.ClickHandler ∈ WidgetFields w) => IPythonWidget w -> IO () triggerClick = triggerEvent ClickHandler -triggerSelection :: (S.SelectionHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()+triggerSelection :: ('S.SelectionHandler ∈ WidgetFields w) => IPythonWidget w -> IO () triggerSelection = triggerEvent SelectionHandler -triggerSubmit :: (S.SubmitHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()+triggerSubmit :: ('S.SubmitHandler ∈ WidgetFields w) => IPythonWidget w -> IO () triggerSubmit = triggerEvent SubmitHandler -triggerDisplay :: (S.DisplayHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()+triggerDisplay :: ('S.DisplayHandler ∈ WidgetFields w) => IPythonWidget w -> IO () triggerDisplay = triggerEvent DisplayHandler