More type-fu

- Remove IHaskell.Display.Widgets.Common
- Partially refactor Button implementation
- Stuck with ToJSON instance for Widget

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

@@ -64,7 +64,6 @@ library
                        IHaskell.Display.Widgets.Output
 
                        IHaskell.Display.Widgets.Types
-                       IHaskell.Display.Widgets.Common
 
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions:    

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

 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
 
 module IHaskell.Display.Widgets.Button (
     -- * The Button Widget
     Button,
     -- * Create a new button
     mkButton,
-    -- * Set button properties
-    setButtonStyle,
-    setButtonLabel,
-    setButtonTooltip,
-    setButtonStatus,
-    toggleButtonStatus,
-    -- * Get button properties
-    getButtonStyle,
-    getButtonLabel,
-    getButtonTooltip,
-    getButtonStatus,
-    -- * Click handlers
-    setClickHandler,
-    getClickHandler,
+    -- * Click manipulation
     triggerClick,
     ) where
 
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Monad (when)
+import           Control.Monad (when, join)
 import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
 import           Data.Aeson.Types (Pair)
-import           Data.HashMap.Strict as Map
+import           Data.Map as M
+import           Data.HashMap.Strict as HashMap
 import           Data.IORef
 import           Data.Text (Text)
 import qualified Data.Text as T
 import           System.IO.Unsafe (unsafePerformIO)
 
-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.Display.Widgets.Common
+import           IHaskell.Display.Widgets.Types
 
 -- | A 'Button' represents a Button from IPython.html.widgets.
-data Button =
-       Button
-         { uuid :: U.UUID       -- ^ The UUID for the comm
-         , description :: IORef Text -- ^ The label displayed on the button
-         , tooltip :: IORef Text     -- ^ The tooltip shown on mouseover
-         , disabled :: IORef Bool    -- ^ Whether the button is disabled
-         , buttonStyle :: IORef ButtonStyle -- ^ The button_style
-         , clickHandler :: IORef (Button -> IO ()) -- ^ Function executed when button is clicked
-         }
+type Button = Widget ButtonType
 
 -- | Create a new button
 mkButton :: IO Button
 mkButton = do
   -- Default properties, with a random uuid
-  commUUID <- U.random
-  desc <- newIORef "label"      -- Non-empty to get a display
-  ttip <- newIORef ""
-  dis <- newIORef False
-  sty <- newIORef None
-  fun <- newIORef $ const $ return ()
-
-  let b = Button
-        { uuid = commUUID
-        , description = desc
-        , tooltip = ttip
-        , disabled = dis
-        , buttonStyle = sty
-        , clickHandler = fun
-        }
+  uuid <- U.random
+
+  let dom = domWidgetWith "ButtonView"
+      but = [ SDescription ~= ""
+            , STooltip ~= ""
+            , SDisabled ~= False
+            , SIcon ~= ""
+            , SButtonStyle ~= DefaultButton
+            , SClickHandler ~= return ()
+            ]
+      attributes = M.fromList $ dom ++ but
+
+  attrIO <- newIORef attributes
+
+  let button = Widget uuid attrIO :: Widget ButtonType
+      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 b (toJSON ButtonInitData) (toJSON b)
+  widgetSendOpen button initData $ toJSON button
 
   -- Return the button widget
-  return b
-
--- | Set the button style
-setButtonStyle :: Button -> ButtonStyle -> IO ()
-setButtonStyle b bst = do
-  modify b buttonStyle bst
-  update b ["button_style" .= bst]
-
--- | Set the button label
-setButtonLabel :: Button -> Text -> IO ()
-setButtonLabel b txt = do
-  modify b description txt
-  update b ["description" .= txt]
-
--- | Set the button tooltip
-setButtonTooltip :: Button -> Text -> IO ()
-setButtonTooltip b txt = do
-  modify b tooltip txt
-  update b ["tooltip" .= txt]
-
--- | Set buttton status. True: Enabled, False: Disabled
-setButtonStatus :: Button -> Bool -> IO ()
-setButtonStatus b stat = do
-  let newStatus = not stat
-  modify b disabled newStatus
-  update b ["disabled" .= newStatus]
-
--- | Toggle the button
-toggleButtonStatus :: Button -> IO ()
-toggleButtonStatus b = do
-  oldVal <- getButtonStatus b
-  let newVal = not oldVal
-  modify b disabled newVal
-  update b ["disabled" .= newVal]
-
--- | Get the button style
-getButtonStyle :: Button -> IO ButtonStyle
-getButtonStyle = readIORef . buttonStyle
-
--- | Get the button label
-getButtonLabel :: Button -> IO Text
-getButtonLabel = readIORef . description
-
--- | Get the button tooltip
-getButtonTooltip :: Button -> IO Text
-getButtonTooltip = readIORef . tooltip
-
--- | Check whether the button is enabled / disabled
-getButtonStatus :: Button -> IO Bool
-getButtonStatus = fmap not . readIORef . disabled
-
--- | Set a function to be activated on click
-setClickHandler :: Button -> (Button -> IO ()) -> IO ()
-setClickHandler = writeIORef . clickHandler
-
--- | Get the click handler for a button
-getClickHandler :: Button -> IO (Button -> IO ())
-getClickHandler = readIORef . clickHandler
+  return button
 
 -- | Artificially trigger a button click
 triggerClick :: Button -> IO ()
-triggerClick button = do
-  handler <- getClickHandler button
-  handler button
-
-data ViewName = ButtonWidget
-
-instance ToJSON ViewName where
-  toJSON ButtonWidget = "ButtonView"
-
-data InitData = ButtonInitData
-
-instance ToJSON InitData where
-  toJSON ButtonInitData = object
-                            [ "model_name" .= str "WidgetModel"
-                            , "widget_class" .= str "IPython.Button"
-                            ]
-
-instance ToJSON Button where
-  toJSON b = object
-               [ "_view_name" .= toJSON ButtonWidget
-               , "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
+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
@@ -179,6 +89,6 @@ instance IHaskellWidget Button where
   comm widget (Object dict1) _ = do
     let key1 = "content" :: Text
         key2 = "event" :: Text
-        Just (Object dict2) = Map.lookup key1 dict1
-        Just (String event) = Map.lookup key2 dict2
+        Just (Object dict2) = HashMap.lookup key1 dict1
+        Just (String event) = HashMap.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 DataKinds #-}
 
 module IHaskell.Display.Widgets.Common (
     -- * Convenience types
-    ButtonStyle(..),
-    ImageFormat(..),
     PosInt(..),
     -- * Convenience functions (for internal use)
     update,
@@ -14,27 +15,9 @@ module IHaskell.Display.Widgets.Common (
 import           Data.Aeson hiding (Success)
 import           Data.Aeson.Types (Pair)
 import qualified Data.Text as T
-import           Data.IORef
-
 import           IHaskell.Display
 import           IHaskell.Eval.Widgets
-
--- | Pre-defined button-styles
-data ButtonStyle = Primary
-                 | Success
-                 | Info
-                 | Warning
-                 | Danger
-                 | None
-  deriving (Eq, Show)
-
-instance ToJSON ButtonStyle where
-  toJSON Primary = "primary"
-  toJSON Success = "success"
-  toJSON Info = "info"
-  toJSON Warning = "warning"
-  toJSON Danger = "danger"
-  toJSON None = ""
+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 }
@@ -44,20 +27,6 @@ instance ToJSON PosInt where
     | n > 0 = toJSON $ str $ show n
     | otherwise = toJSON $ str $ ""
 
--- | Image formats for ImageWidget
-data ImageFormat = PNG
-                 | SVG
-                 | JPG
-  deriving Eq
-
-instance Show ImageFormat where
-  show PNG = "png"
-  show SVG = "svg"
-  show JPG = "jpg"
-
-instance ToJSON ImageFormat where
-  toJSON = toJSON . T.pack . show
-
 -- | 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 ()
@@ -66,7 +35,3 @@ update widget = widgetSendUpdate widget . toJSON . object
 -- | 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
-
--- | Useful with toJSON
-str :: String -> String
-str = id