Ultimate type-fu ~ A lot of vinyl

- Widgets work, although it requires some tweaking to their properties.
- Dropping dropdown for now. Will deal with selection widgets later.
- Default properties need to be improved.

ihaskell-display/ihaskell-widgets/ihaskell-widgets.cabal

@@ -56,7 +56,7 @@ library
   -- Modules included in this library but not exported.
   other-modules:       IHaskell.Display.Widgets.Button
                        IHaskell.Display.Widgets.Image
-                       IHaskell.Display.Widgets.Dropdown
+                       -- IHaskell.Display.Widgets.Dropdown
                        IHaskell.Display.Widgets.String.HTML
                        IHaskell.Display.Widgets.String.Latex
                        IHaskell.Display.Widgets.String.Text
@@ -64,6 +64,7 @@ library
                        IHaskell.Display.Widgets.Output
 
                        IHaskell.Display.Widgets.Types
+                       IHaskell.Display.Widgets.Common
 
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions:    
@@ -77,6 +78,7 @@ library
                      , unordered-containers >= 0.2.5.1
 
                        -- TODO: Need to check versions
+                     , vinyl -any
                      , singletons -any
 
                        -- Waiting for the next release

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets.hs

@@ -2,7 +2,7 @@ module IHaskell.Display.Widgets (module X) where
 
 import           IHaskell.Display.Widgets.Button as X
 
-import           IHaskell.Display.Widgets.Dropdown as X
+-- import           IHaskell.Display.Widgets.Dropdown as X
 
 import           IHaskell.Display.Widgets.Image as X
 
@@ -13,4 +13,5 @@ import           IHaskell.Display.Widgets.String.TextArea as X
 
 import           IHaskell.Display.Widgets.Output as X
 
-import           IHaskell.Display.Widgets.Common as X (ButtonStyle(..), ImageFormat(..))
+import           IHaskell.Display.Widgets.Common as X
+import           IHaskell.Display.Widgets.Types as X (setField, setField', getField)

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Button.hs

 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module IHaskell.Display.Widgets.Button (
     -- * The Button Widget
@@ -15,21 +16,18 @@ module IHaskell.Display.Widgets.Button (
 import           Prelude
 
 import           Control.Monad (when, join)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair)
-import           Data.Map as M
-import           Data.HashMap.Strict as HashMap
-import           Data.IORef
+import           Data.Aeson
+import           Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
 import           Data.Text (Text)
-import qualified Data.Text as T
-import           System.IO.Unsafe (unsafePerformIO)
+import           Data.Vinyl (Rec (..), (<+>))
 
 import           IHaskell.Display hiding (Widget)
 import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
-import           IHaskell.Types (WidgetMethod(..))
+import           IHaskell.IPython.Message.UUID as U
 
 import           IHaskell.Display.Widgets.Types
+import           IHaskell.Display.Widgets.Common
 
 -- | A 'Button' represents a Button from IPython.html.widgets.
 type Button = Widget ButtonType
@@ -40,23 +38,27 @@ mkButton = do
   -- Default properties, with a random uuid
   uuid <- U.random
 
-  let dom = domWidgetWith "ButtonView"
-      but = [ SDescription ~= ""
-            , STooltip ~= ""
-            , SDisabled ~= False
-            , SIcon ~= ""
-            , SButtonStyle ~= DefaultButton
-            , SClickHandler ~= return ()
-            ]
-      attributes = M.fromList $ dom ++ but
+  let dom = defaultDOMWidget "ButtonView"
+      but = (SDescription =:: "")
+         :& (STooltip =:: "")
+         :& (SDisabled =:: False)
+         :& (SIcon =:: "")
+         :& (SButtonStyle =:: DefaultButton)
+         :& (SClickHandler =:: return ())
+         :& RNil
+      buttonState = WidgetState (dom <+> but)
+
+  stateIO <- newIORef buttonState
 
-  attrIO <- newIORef attributes
+  let button = Widget uuid stateIO
 
-  let button = Widget uuid attrIO :: Widget ButtonType
-      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Button"]
+  let initData = object
+                   [ "model_name" .= str "WidgetModel"
+                   , "widget_class" .= str "IPython.Button"
+                   ]
 
   -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen button initData $ toJSON button
+  widgetSendOpen button initData $ toJSON buttonState
 
   -- Return the button widget
   return button
@@ -65,20 +67,6 @@ mkButton = do
 triggerClick :: Button -> IO ()
 triggerClick button = join $ getField button SClickHandler
 
--- instance ToJSON Button where
---   toJSON b = object
---                [ "_view_name" .= str "ButtonView"
---                , "visible" .= True
---                , "_css" .= object []
---                , "msg_throttle" .= (3 :: Int)
---                , "disabled" .= get disabled b
---                , "description" .= get description b
---                , "tooltip" .= get tooltip b
---                , "button_style" .= get buttonStyle b
---                ]
---     where
---       get x y = unsafePerformIO . readIORef . x $ y
-
 instance IHaskellDisplay Button where
   display b = do
     widgetSendView b
@@ -89,6 +77,6 @@ instance IHaskellWidget Button where
   comm widget (Object dict1) _ = do
     let key1 = "content" :: Text
         key2 = "event" :: Text
-        Just (Object dict2) = HashMap.lookup key1 dict1
-        Just (String event) = HashMap.lookup key2 dict2
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (String event) = HM.lookup key2 dict2
     when (event == "click") $ triggerClick widget

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

-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+module IHaskell.Display.Widgets.Common where
+
+import Control.Monad (when)
+
+import Data.Aeson
+import Data.Aeson.Types (emptyObject, Pair)
+import Data.Text (pack, Text)
+import Data.IORef (IORef, readIORef, modifyIORef)
+import Data.Proxy
+
+import Data.Vinyl (Rec (..), (<+>), recordToList, reifyConstraint, rmap, Dict (..))
+import Data.Vinyl.Functor (Compose (..), Const (..))
+import Data.Vinyl.Lens (rget, rput, type (∈))
+import qualified Data.Vinyl.TypeLevel as TL
+
+import Data.Singletons.TH
 
-module IHaskell.Display.Widgets.Common (
-    -- * Convenience types
-    PosInt(..),
-    -- * Convenience functions (for internal use)
-    update,
-    modify,
-    str,
-    ) where
-
-import           Data.Aeson hiding (Success)
-import           Data.Aeson.Types (Pair)
-import qualified Data.Text as T
-import           IHaskell.Display
-import           IHaskell.Eval.Widgets
+import IHaskell.Eval.Widgets (widgetSendUpdate)
+import IHaskell.Display (Base64, IHaskellWidget (..))
 import IHaskell.IPython.Message.UUID
 
--- | A wrapper around Int. 'toJSON' gives the no. for positive numbers, and empty string otherwise
-newtype PosInt = PosInt { unwrap :: Int }
+-- Widget properties
+singletons [d|
+  data Field = ModelModule
+             | ModelName
+             | ViewModule
+             | ViewName
+             | MsgThrottle
+             | Version
+             | OnDisplayed
+             | Visible
+             | CSS
+             | DOMClasses
+             | Width
+             | Height
+             | Padding
+             | Margin
+             | Color
+             | BackgroundColor
+             | BorderColor
+             | BorderWidth
+             | BorderRadius
+             | BorderStyle
+             | FontStyle
+             | FontWeight
+             | FontSize
+             | FontFamily
+             | Description
+             | ClickHandler
+             | SubmitHandler
+             | Disabled
+             | StringValue
+             | Placeholder
+             | Tooltip
+             | Icon
+             | ButtonStyle
+             | B64Value
+             | ImageFormat
+             deriving (Eq, Ord, Show)
+             |]
+
+data BorderStyleValue = NoBorder
+                      | HiddenBorder
+                      | DottedBorder
+                      | DashedBorder
+                      | SolidBorder
+                      | DoubleBorder
+                      | GrooveBorder
+                      | RidgeBorder
+                      | InsetBorder
+                      | OutsetBorder
+                      | InitialBorder
+                      | InheritBorder
+                      | DefaultBorder
+
+instance ToJSON BorderStyleValue where
+  toJSON NoBorder = "none"
+  toJSON HiddenBorder = "hidden"
+  toJSON DottedBorder = "dotted"
+  toJSON DashedBorder = "dashed"
+  toJSON SolidBorder = "solid"
+  toJSON DoubleBorder = "double"
+  toJSON GrooveBorder = "groove"
+  toJSON RidgeBorder = "ridge"
+  toJSON InsetBorder = "inset"
+  toJSON OutsetBorder = "outset"
+  toJSON InitialBorder = "initial"
+  toJSON InheritBorder = "inherit"
+  toJSON DefaultBorder = ""
+
+data FontStyleValue = NormalFont
+                    | ItalicFont
+                    | ObliqueFont
+                    | InitialFont
+                    | InheritFont
+                    | DefaultFont
+
+instance ToJSON FontStyleValue where
+  toJSON NormalFont = "normal"
+  toJSON ItalicFont = "italic"
+  toJSON ObliqueFont = "oblique"
+  toJSON InitialFont = "initial"
+  toJSON InheritFont = "inherit"
+  toJSON DefaultFont = ""
+
+data FontWeightValue = NormalWeight
+                     | BoldWeight
+                     | BolderWeight
+                     | LighterWeight
+                     | InheritWeight
+                     | InitialWeight
+                     | DefaultWeight
+
+instance ToJSON FontWeightValue where
+  toJSON NormalWeight = "normal"
+  toJSON BoldWeight = "bold"
+  toJSON BolderWeight = "bolder"
+  toJSON LighterWeight = "lighter"
+  toJSON InheritWeight = "inherit"
+  toJSON InitialWeight = "initial"
+  toJSON DefaultWeight = ""
+
+data ButtonStyleValue = PrimaryButton
+                      | SuccessButton
+                      | InfoButton
+                      | WarningButton
+                      | DangerButton
+                      | DefaultButton
+
+instance ToJSON ButtonStyleValue where
+  toJSON PrimaryButton = "primary"
+  toJSON SuccessButton = "success"
+  toJSON InfoButton = "info"
+  toJSON WarningButton = "warning"
+  toJSON DangerButton = "danger"
+  toJSON DefaultButton = ""
 
-instance ToJSON PosInt where
-  toJSON (PosInt n)
-    | n > 0 = toJSON $ str $ show n
-    | otherwise = toJSON $ str $ ""
+-- | Image formats for ImageWidget
+data ImageFormatValue = PNG
+                      | SVG
+                      | JPG
+  deriving Eq
 
--- | Send an update msg for a widget, with custom json. Make it easy to update fragments of the
--- state, by accepting a Pair instead of a Value.
-update :: IHaskellWidget a => a -> [Pair] -> IO ()
-update widget = widgetSendUpdate widget . toJSON . object
+instance Show ImageFormatValue where
+  show PNG = "png"
+  show SVG = "svg"
+  show JPG = "jpg"
 
--- | Modify attributes of a widget, stored inside it as IORefs
-modify :: IHaskellWidget a => a -> (a -> IORef b) -> b -> IO ()
-modify widget attr newval = writeIORef (attr widget) newval
+instance ToJSON ImageFormatValue where
+  toJSON = toJSON . pack . show

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Image.hs

 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module IHaskell.Display.Widgets.Image (
     -- * The Image Widget
     ImageWidget,
-    -- * Create a new image widget
+    -- * Constructor
     mkImageWidget,
-    -- * Set image properties
-    setImageFormat,
-    setImageB64Value,
-    setImageWidth,
-    setImageHeight,
-    -- * Get image properties
-    getImageFormat,
-    getImageB64Value,
-    getImageWidth,
-    getImageHeight,
     ) where
 
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Monad (when)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair)
-import           Data.HashMap.Strict as Map
-import           Data.IORef
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
 import           Data.Text (Text)
-import qualified Data.Text as T
-import           System.IO.Unsafe (unsafePerformIO)
+import           Data.Vinyl (Rec (..), (<+>))
 
-import           IHaskell.Display
+import           IHaskell.Display hiding (Widget)
 import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
-import           IHaskell.Types (WidgetMethod(..))
+import           IHaskell.IPython.Message.UUID as U
 
+import           IHaskell.Display.Widgets.Types
 import           IHaskell.Display.Widgets.Common
 
--- | A 'Image' represents a Image from IPython.html.widgets.
-data ImageWidget =
-       ImageWidget
-         { uuid :: U.UUID
-         , format :: IORef ImageFormat
-         , height :: IORef PosInt
-         , width :: IORef PosInt
-         , b64value :: IORef Base64
-         }
+-- | An 'ImageWidget' represents a Image widget from IPython.html.widgets.
+type ImageWidget = Widget ImageType
 
 -- | Create a new image widget
 mkImageWidget :: IO ImageWidget
 mkImageWidget = do
   -- Default properties, with a random uuid
-  commUUID <- U.random
-  fmt <- newIORef PNG
-  hgt <- newIORef (PosInt 0)
-  wdt <- newIORef (PosInt 0)
-  val <- newIORef ""
+  uuid <- U.random
 
-  let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Image"]
-      b = ImageWidget { uuid = commUUID, format = fmt, height = hgt, width = wdt, b64value = val }
+  let dom = defaultDOMWidget "ImageView"
+      img = (SImageFormat =:: PNG)
+         :& (SB64Value =:: mempty)
+         :& RNil
+      widgetState = WidgetState (dom <+> img)
 
-  -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen b initData (toJSON b)
-
-  -- Return the image widget
-  return b
-
--- | Set the image style
-setImageFormat :: ImageWidget -> ImageFormat -> IO ()
-setImageFormat b fmt = do
-  modify b format fmt
-  update b ["format" .= fmt]
-
--- | Set the image value (encoded in base64)
-setImageB64Value :: ImageWidget -> Base64 -> IO ()
-setImageB64Value b val = do
-  modify b b64value val
-  update b ["_b64value" .= val]
-
--- | Set the image width
-setImageWidth :: ImageWidget -> Int -> IO ()
-setImageWidth b wdt = do
-  let w = PosInt wdt
-  modify b width w
-  update b ["width" .= w]
+  stateIO <- newIORef widgetState
 
--- | Set the image height
-setImageHeight :: ImageWidget -> Int -> IO ()
-setImageHeight b hgt = do
-  let h = PosInt hgt
-  modify b height h
-  update b ["height" .= h]
+  let widget = Widget uuid stateIO
 
--- | Get the image format
-getImageFormat :: ImageWidget -> IO ImageFormat
-getImageFormat = readIORef . format
-
--- | Get the image value (encoded in base64)
-getImageB64Value :: ImageWidget -> IO Base64
-getImageB64Value = readIORef . b64value
-
--- | Get the image width
-getImageWidth :: ImageWidget -> IO Int
-getImageWidth = fmap unwrap . readIORef . width
+  let initData = object
+                   [ "model_name" .= str "WidgetModel"
+                   , "widget_class" .= str "IPython.Image"
+                   ]
 
--- | Get the image height
-getImageHeight :: ImageWidget -> IO Int
-getImageHeight = fmap unwrap . readIORef . height
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
 
-instance ToJSON ImageWidget where
-  toJSON b = object
-               [ "_view_module" .= str ""
-               , "background_color" .= str ""
-               , "border_width" .= str ""
-               , "border_color" .= str ""
-               , "width" .= get width b
-               , "_dom_classes" .= object []
-               , "margin" .= str ""
-               , "font_style" .= str ""
-               , "font_weight" .= str ""
-               , "height" .= get height b
-               , "font_size" .= str ""
-               , "border_style" .= str ""
-               , "padding" .= str ""
-               , "border_radius" .= str ""
-               , "version" .= (0 :: Int)
-               , "font_family" .= str ""
-               , "color" .= str ""
-               , "_view_name" .= str "ImageView"
-               , "visible" .= True
-               , "_css" .= object []
-               , "msg_throttle" .= (3 :: Int)
-               , "format" .= get format b
-               , "_b64value" .= get b64value b
-               ]
-    where
-      get x y = unsafePerformIO . readIORef . x $ y
+  -- Return the image widget
+  return widget
 
 instance IHaskellDisplay ImageWidget where
   display b = do

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Output.hs

 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module IHaskell.Display.Widgets.Output (
     -- * The Output Widget
     OutputWidget,
     -- * Constructor
     mkOutputWidget,
-    -- * Get/Set/Modify width
-    getOutputWidth,
-    setOutputWidth,
-    modifyOutputWidth,
-    modifyOutputWidth_,
-    -- * Output to widget
+    -- * Using the output widget
     appendOutput,
     clearOutput,
     clearOutput_,
@@ -21,62 +18,40 @@ module IHaskell.Display.Widgets.Output (
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Monad (when, void)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair, Array)
-import qualified Data.HashMap.Strict as Map
-import           Data.IORef
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
 import           Data.Text (Text)
-import qualified Data.Text as T
-import           System.IO.Unsafe (unsafePerformIO)
+import           Data.Vinyl (Rec (..), (<+>))
 
-import           IHaskell.Display
+import           IHaskell.Display hiding (Widget)
 import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
-import           IHaskell.Types (WidgetMethod(..))
+import           IHaskell.IPython.Message.UUID as U
 
-import           IHaskell.Display.Widgets.Common
+import           IHaskell.Display.Widgets.Types
 
-data OutputWidget = OutputWidget { uuid :: U.UUID, width :: IORef PosInt }
+-- | An 'OutputWidget' represents a Output widget from IPython.html.widgets.
+type OutputWidget = Widget OutputType
 
+-- | Create a new output widget
 mkOutputWidget :: IO OutputWidget
 mkOutputWidget = do
   -- Default properties, with a random uuid
-  commUUID <- U.random
-  wdt <- newIORef $ PosInt 400
-  dis <- newIORef False
+  uuid <- U.random
 
-  let b = OutputWidget { uuid = commUUID, width = wdt }
+  let widgetState = WidgetState $ defaultDOMWidget "OutputView"
 
-  let initData = object ["model_name" .= str "WidgetModel"]
+  stateIO <- newIORef widgetState
 
-  -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen b initData (toJSON b)
-
-  -- Return the widget
-  return b
-
--- | Get the output widget width
-getOutputWidth :: OutputWidget -> IO Int
-getOutputWidth = fmap unwrap . readIORef . width
+  let widget = Widget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel"]
 
--- | Set the output widget width
-setOutputWidth :: OutputWidget -> Int -> IO ()
-setOutputWidth widget widthInt = do
-  let w = PosInt widthInt
-  modify widget width w
-  update widget ["width" .= w]
-
--- | Modify the output widget width (with IO)
-modifyOutputWidth :: OutputWidget -> (Int -> IO Int) -> IO ()
-modifyOutputWidth widget modifier = getOutputWidth widget >>= modifier >>= setOutputWidth widget
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
 
--- | Modify the output widget width (with pure modifier)
-modifyOutputWidth_ :: OutputWidget -> (Int -> Int) -> IO ()
-modifyOutputWidth_ widget modifier = do
-  w <- getOutputWidth widget
-  let newWidth = modifier w
-  setOutputWidth widget newWidth
+  -- Return the image widget
+  return widget
 
 -- | Append to the output widget
 appendOutput :: IHaskellDisplay a => OutputWidget -> a -> IO ()
@@ -98,33 +73,6 @@ replaceOutput widget d = do
   clearOutput_ widget
   appendOutput widget d
 
-instance ToJSON OutputWidget where
-  toJSON b = object
-               [ "_view_module" .= str ""
-               , "background_color" .= str ""
-               , "border_width" .= str ""
-               , "border_color" .= str ""
-               , "width" .= get width b
-               , "_dom_classes" .= object []
-               , "margin" .= str ""
-               , "font_style" .= str ""
-               , "font_weight" .= str ""
-               , "height" .= str ""
-               , "font_size" .= str ""
-               , "border_style" .= str ""
-               , "padding" .= str ""
-               , "border_radius" .= str ""
-               , "version" .= (0 :: Int)
-               , "font_family" .= str ""
-               , "color" .= str ""
-               , "_view_name" .= str "OutputView"
-               , "visible" .= True
-               , "_css" .= object []
-               , "msg_throttle" .= (3 :: Int)
-               ]
-    where
-      get x = unsafePerformIO . readIORef . x
-
 instance IHaskellDisplay OutputWidget where
   display b = do
     widgetSendView b

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/HTML.hs

+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module IHaskell.Display.Widgets.String.HTML (
     -- * The HTML Widget
     HTMLWidget,
     -- * Constructor
     mkHTMLWidget,
-    -- * Set properties
-    setHTMLValue,
-    setHTMLDescription,
-    setHTMLPlaceholder,
-    -- * Get properties
-    getHTMLValue,
-    getHTMLDescription,
-    getHTMLPlaceholder,
     ) where
 
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Monad (when)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair)
-import           Data.HashMap.Strict as Map
-import           Data.IORef
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.IORef (newIORef)
 import           Data.Text (Text)
-import qualified Data.Text as T
-import           System.IO.Unsafe (unsafePerformIO)
+import           Data.Vinyl (Rec (..), (<+>))
 
-import           IHaskell.Display
+import           IHaskell.Display hiding (Widget)
 import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
+import           IHaskell.IPython.Message.UUID as U
 
-import           IHaskell.Display.Widgets.Common
+import           IHaskell.Display.Widgets.Types
 
-data HTMLWidget =
-       HTMLWidget
-         { uuid :: U.UUID
-         , value :: IORef Text
-         , description :: IORef Text
-         , placeholder :: IORef Text
-         }
+-- | A 'HTMLWidget' represents a HTML widget from IPython.html.widgets.
+type HTMLWidget = Widget HTMLType
 
 -- | Create a new HTML widget
 mkHTMLWidget :: IO HTMLWidget
 mkHTMLWidget = do
   -- Default properties, with a random uuid
-  commUUID <- U.random
-  val <- newIORef ""
-  des <- newIORef ""
-  plc <- newIORef ""
+  uuid <- U.random
+  let widgetState = WidgetState $ defaultStringWidget "HTMLView"
 
-  let b = HTMLWidget { uuid = commUUID, value = val, description = des, placeholder = plc }
+  stateIO <- newIORef widgetState
 
-  let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.HTML"]
+  let widget = Widget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.HTML"]
 
   -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen b initData (toJSON b)
+  widgetSendOpen widget initData $ toJSON widgetState
 
-  -- Return the string widget
-  return b
-
--- | Set the HTML string value.
-setHTMLValue :: HTMLWidget -> Text -> IO ()
-setHTMLValue b txt = do
-  modify b value txt
-  update b ["value" .= txt]
-
--- | Set the HTML description
-setHTMLDescription :: HTMLWidget -> Text -> IO ()
-setHTMLDescription b txt = do
-  modify b description txt
-  update b ["description" .= txt]
-
--- | Set the HTML placeholder, i.e. text displayed in empty widget
-setHTMLPlaceholder :: HTMLWidget -> Text -> IO ()
-setHTMLPlaceholder b txt = do
-  modify b placeholder txt
-  update b ["placeholder" .= txt]
-
--- | Get the HTML string value.
-getHTMLValue :: HTMLWidget -> IO Text
-getHTMLValue = readIORef . value
-
--- | Get the HTML description value.
-getHTMLDescription :: HTMLWidget -> IO Text
-getHTMLDescription = readIORef . description
-
--- | Get the HTML placeholder value.
-getHTMLPlaceholder :: HTMLWidget -> IO Text
-getHTMLPlaceholder = readIORef . placeholder
-
-instance ToJSON HTMLWidget where
-  toJSON b = object
-               [ "_view_name" .= str "HTMLView"
-               , "visible" .= True
-               , "_css" .= object []
-               , "msg_throttle" .= (3 :: Int)
-               , "value" .= get value b
-               ]
-    where
-      get x y = unsafePerformIO . readIORef . x $ y
+  -- Return the widget
+  return widget
 
 instance IHaskellDisplay HTMLWidget where
   display b = do

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/Latex.hs

+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module IHaskell.Display.Widgets.String.Latex (
     -- * The Latex Widget
     LatexWidget,
     -- * Constructor
     mkLatexWidget,
-    -- * Set properties
-    setLatexValue,
-    setLatexPlaceholder,
-    setLatexDescription,
-    setLatexWidth,
-    -- * Get properties
-    getLatexValue,
-    getLatexPlaceholder,
-    getLatexDescription,
-    getLatexWidth,
     ) where
 
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Monad (when)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair)
-import           Data.HashMap.Strict as Map
-import           Data.IORef
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.IORef (newIORef)
 import           Data.Text (Text)
-import qualified Data.Text as T
-import           System.IO.Unsafe (unsafePerformIO)
+import           Data.Vinyl (Rec (..), (<+>))
 
-import           IHaskell.Display
+import           IHaskell.Display hiding (Widget)
 import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
+import           IHaskell.IPython.Message.UUID as U
 
-import           IHaskell.Display.Widgets.Common
+import           IHaskell.Display.Widgets.Types
 
-data LatexWidget =
-       LatexWidget
-         { uuid :: U.UUID
-         , value :: IORef Text
-         , description :: IORef Text
-         , placeholder :: IORef Text
-         , width :: IORef Int
-         }
+-- | A 'LatexWidget' represents a Latex widget from IPython.html.widgets.
+type LatexWidget = Widget LatexType
 
 -- | Create a new Latex widget
 mkLatexWidget :: IO LatexWidget
 mkLatexWidget = do
   -- Default properties, with a random uuid
-  commUUID <- U.random
-  val <- newIORef ""
-  des <- newIORef ""
-  plc <- newIORef ""
-  width <- newIORef 400
+  uuid <- U.random
+  let widgetState = WidgetState $ defaultStringWidget "LatexView"
 
-  let b = LatexWidget
-        { uuid = commUUID
-        , value = val
-        , description = des
-        , placeholder = plc
-        , width = width
-        }
+  stateIO <- newIORef widgetState
 
-  let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Latex"]
+  let widget = Widget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Latex"]
 
   -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen b initData (toJSON b)
+  widgetSendOpen widget initData $ toJSON widgetState
 
-  -- Return the string widget
-  return b
-
--- | Set the Latex string value.
-setLatexValue :: LatexWidget -> Text -> IO ()
-setLatexValue b txt = do
-  modify b value txt
-  update b ["value" .= txt]
-
--- | Set the Latex description
-setLatexDescription :: LatexWidget -> Text -> IO ()
-setLatexDescription b txt = do
-  modify b description txt
-  update b ["description" .= txt]
-
--- | Set the Latex placeholder, i.e. text displayed in empty widget
-setLatexPlaceholder :: LatexWidget -> Text -> IO ()
-setLatexPlaceholder b txt = do
-  modify b placeholder txt
-  update b ["placeholder" .= txt]
-
--- | Set the Latex widget width.
-setLatexWidth :: LatexWidget -> Int -> IO ()
-setLatexWidth b wid = do
-  modify b width wid
-  update b ["width" .= wid]
-
--- | Get the Latex string value.
-getLatexValue :: LatexWidget -> IO Text
-getLatexValue = readIORef . value
-
--- | Get the Latex description value.
-getLatexDescription :: LatexWidget -> IO Text
-getLatexDescription = readIORef . description
-
--- | Get the Latex placeholder value.
-getLatexPlaceholder :: LatexWidget -> IO Text
-getLatexPlaceholder = readIORef . placeholder
-
--- | Get the Latex widget width.
-getLatexWidth :: LatexWidget -> IO Int
-getLatexWidth = readIORef . width
-
-instance ToJSON LatexWidget where
-  toJSON b = object
-               [ "_view_name" .= str "LatexView"
-               , "visible" .= True
-               , "_css" .= object []
-               , "msg_throttle" .= (3 :: Int)
-               , "value" .= get value b
-               ]
-    where
-      get x y = unsafePerformIO . readIORef . x $ y
+  -- Return the widget
+  return widget
 
 instance IHaskellDisplay LatexWidget where
   display b = do

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

+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module IHaskell.Display.Widgets.String.Text (
     -- * The Text Widget
     TextWidget,
     -- * Constructor
     mkTextWidget,
-    -- * Set properties
-    setTextValue,
-    setTextDescription,
-    setTextPlaceholder,
-    -- * Get properties
-    getTextValue,
-    getTextDescription,
-    getTextPlaceholder,
     -- * Submit handling
-    setSubmitHandler,
-    getSubmitHandler,
     triggerSubmit,
     ) where
 
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Monad (when, void)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair)
-import           Data.HashMap.Strict as Map
-import           Data.IORef
+import           Control.Monad (when, join)
+import           Data.Aeson
+import qualified Data.HashMap.Strict as Map
+import           Data.IORef (newIORef)
 import           Data.Text (Text)
-import qualified Data.Text as T
-import           System.IO.Unsafe (unsafePerformIO)
+import           Data.Vinyl (Rec (..), (<+>))
 
-import           IHaskell.Display
+import           IHaskell.Display hiding (Widget)
 import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
+import           IHaskell.IPython.Message.UUID as U
 
+import           IHaskell.Display.Widgets.Types
 import           IHaskell.Display.Widgets.Common
 
-data TextWidget =
-       TextWidget
-         { uuid :: U.UUID
-         , value :: IORef Text
-         , description :: IORef Text
-         , placeholder :: IORef Text
-         , submitHandler :: IORef (TextWidget -> IO ())
-         }
+-- | A 'TextWidget' represents a Text widget from IPython.html.widgets.
+type TextWidget = Widget TextType
 
 -- | Create a new Text widget
 mkTextWidget :: IO TextWidget
 mkTextWidget = do
   -- Default properties, with a random uuid
-  commUUID <- U.random
-  val <- newIORef ""
-  des <- newIORef ""
-  plc <- newIORef ""
-  sh <- newIORef $ const $ return ()
+  uuid <- U.random
+  let strWidget = defaultStringWidget "TextView"
+      txtWidget = (SSubmitHandler =:: return ()) :& RNil
+      widgetState = WidgetState $ strWidget <+> txtWidget
 
-  let b = TextWidget
-        { uuid = commUUID
-        , value = val
-        , description = des
-        , placeholder = plc
-        , submitHandler = sh
-        }
+  stateIO <- newIORef widgetState
 
-  let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Text"]
+  let widget = Widget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Text"]
 
   -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen b initData (toJSON b)
+  widgetSendOpen widget initData $ toJSON widgetState
 
-  -- Return the string widget
-  return b
+  -- Return the widget
+  return widget
 
--- | Set the Text string value.
-setTextValue :: TextWidget -> Text -> IO ()
-setTextValue b txt = do
-  modify b value txt
-  update b ["value" .= txt]
-
--- | Set the text widget "description"
-setTextDescription :: TextWidget -> Text -> IO ()
-setTextDescription b txt = do
-  modify b description txt
-  update b ["description" .= txt]
-
--- | Set the text widget "placeholder", i.e. text displayed in empty text widget
-setTextPlaceholder :: TextWidget -> Text -> IO ()
-setTextPlaceholder b txt = do
-  modify b placeholder txt
-  update b ["placeholder" .= txt]
-
--- | Get the Text string value.
-getTextValue :: TextWidget -> IO Text
-getTextValue = readIORef . value
-
--- | Get the Text widget "description" value.
-getTextDescription :: TextWidget -> IO Text
-getTextDescription = readIORef . description
-
--- | Get the Text widget placeholder value.
-getTextPlaceholder :: TextWidget -> IO Text
-getTextPlaceholder = readIORef . placeholder
-
--- | Set a function to be activated on click
-setSubmitHandler :: TextWidget -> (TextWidget -> IO ()) -> IO ()
-setSubmitHandler = writeIORef . submitHandler
-
--- | Get the submit handler for a TextWidget
-getSubmitHandler :: TextWidget -> IO (TextWidget -> IO ())
-getSubmitHandler = readIORef . submitHandler
-
--- | Artificially trigger a TextWidget submit
 triggerSubmit :: TextWidget -> IO ()
-triggerSubmit tw = do
-  handler <- getSubmitHandler tw
-  handler tw
-
-instance ToJSON TextWidget where
-  toJSON b = object
-               [ "_view_name" .= str "TextView"
-               , "visible" .= True
-               , "_css" .= object []
-               , "msg_throttle" .= (3 :: Int)
-               , "value" .= get value b
-               , "description" .= get description b
-               , "placeholder" .= get placeholder b
-               ]
-    where
-      get x y = unsafePerformIO . readIORef . x $ y
+triggerSubmit tw = join $ getField tw SSubmitHandler
 
 instance IHaskellDisplay TextWidget where
   display b = do
@@ -141,7 +67,7 @@ instance IHaskellWidget TextWidget where
     case Map.lookup "sync_data" dict1 of
       Just (Object dict2) ->
         case Map.lookup "value" dict2 of
-          Just (String val) -> setTextValue tw val
+          Just (String val) -> setField' tw SStringValue val
           Nothing           -> return ()
       Nothing ->
         case Map.lookup "content" dict1 of

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/TextArea.hs

+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module IHaskell.Display.Widgets.String.TextArea (
     -- * The TextArea Widget
     TextAreaWidget,
     -- * Constructor
     mkTextAreaWidget,
-    -- * Set properties
-    setTextAreaValue,
-    setTextAreaDescription,
-    setTextAreaPlaceholder,
-    -- * Get properties
-    getTextAreaValue,
-    getTextAreaDescription,
-    getTextAreaPlaceholder,
     ) where
 
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Monad (when)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair)
-import           Data.HashMap.Strict as Map
-import           Data.IORef
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.IORef (newIORef)
 import           Data.Text (Text)
-import qualified Data.Text as T
-import           System.IO.Unsafe (unsafePerformIO)
+import           Data.Vinyl (Rec (..), (<+>))
 
-import           IHaskell.Display
+import           IHaskell.Display hiding (Widget)
 import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
+import           IHaskell.IPython.Message.UUID as U
 
-import           IHaskell.Display.Widgets.Common
+import           IHaskell.Display.Widgets.Types
 
-data TextAreaWidget =
-       TextAreaWidget
-         { uuid :: U.UUID
-         , value :: IORef Text
-         , description :: IORef Text
-         , placeholder :: IORef Text
-         }
+-- | A 'TextAreaWidget' represents a Textarea widget from IPython.html.widgets.
+type TextAreaWidget = Widget TextAreaType
 
 -- | Create a new TextArea widget
 mkTextAreaWidget :: IO TextAreaWidget
 mkTextAreaWidget = do
   -- Default properties, with a random uuid
-  commUUID <- U.random
-  val <- newIORef ""
-  des <- newIORef ""
-  plc <- newIORef ""
+  uuid <- U.random
+  let widgetState = WidgetState $ defaultStringWidget "TextareaView"
 
-  let b = TextAreaWidget { uuid = commUUID, value = val, description = des, placeholder = plc }
+  stateIO <- newIORef widgetState
 
-  let initData = object
-                   ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Textarea"]
+  let widget = Widget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Textarea"]
 
   -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen b initData (toJSON b)
+  widgetSendOpen widget initData $ toJSON widgetState
 
-  -- Return the string widget
-  return b
-
--- | Set the TextArea string value.
-setTextAreaValue :: TextAreaWidget -> Text -> IO ()
-setTextAreaValue b txt = do
-  modify b value txt
-  update b ["value" .= txt]
-
--- | Set the TextArea widget "description"
-setTextAreaDescription :: TextAreaWidget -> Text -> IO ()
-setTextAreaDescription b txt = do
-  modify b description txt
-  update b ["description" .= txt]
-
--- | Set the TextArea widget "placeholder", i.e. text displayed in empty widget
-setTextAreaPlaceholder :: TextAreaWidget -> Text -> IO ()
-setTextAreaPlaceholder b txt = do
-  modify b placeholder txt
-  update b ["placeholder" .= txt]
-
--- | Get the TextArea string value.
-getTextAreaValue :: TextAreaWidget -> IO Text
-getTextAreaValue = readIORef . value
-
--- | Get the TextArea widget "description" value.
-getTextAreaDescription :: TextAreaWidget -> IO Text
-getTextAreaDescription = readIORef . description
-
--- | Get the TextArea widget placeholder value.
-getTextAreaPlaceholder :: TextAreaWidget -> IO Text
-getTextAreaPlaceholder = readIORef . placeholder
-
-instance ToJSON TextAreaWidget where
-  toJSON b = object
-               [ "_view_name" .= str "TextareaView"
-               , "visible" .= True
-               , "_css" .= object []
-               , "msg_throttle" .= (3 :: Int)
-               , "value" .= get value b
-               , "description" .= get description b
-               , "placeholder" .= get placeholder b
-               ]
-    where
-      get x y = unsafePerformIO . readIORef . x $ y
+  -- Return the widget
+  return widget
 
 instance IHaskellDisplay TextAreaWidget where
   display b = do