Adding 3/4 string widget

- HTMLWidget and LatexWidget work fine.
- TextWidget still doesn't work.
- TextareaWidget not implemented yet.

* All widgets raise a lot of errors in the webconsole.

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

@@ -55,6 +55,7 @@ library
   
   -- Modules included in this library but not exported.
   other-modules:       IHaskell.Display.Widgets.Button
+                       IHaskell.Display.Widgets.Common
   
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions:    

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

@@ -4,8 +4,6 @@
 module IHaskell.Display.Widgets.Button (
     -- * The Button Widget
     Button,
-    -- * Predefined button styles
-    ButtonStyle(..),
     -- * Create a new button
     mkButton,
     -- * Set button properties
@@ -42,6 +40,8 @@ import           IHaskell.Eval.Widgets
 import qualified IHaskell.IPython.Message.UUID as U
 import           IHaskell.Types (WidgetMethod(..))
 
+import           IHaskell.Display.Widgets.Common (ButtonStyle (..))
+
 -- | A 'Button' represents a Button from IPython.html.widgets.
 data Button =
        Button
@@ -53,15 +53,6 @@ data Button =
          , clickHandler :: IORef (Button -> IO ()) -- ^ Function executed when button is clicked
          }
 
--- | Pre-defined button-styles
-data ButtonStyle = Primary
-                 | Success
-                 | Info
-                 | Warning
-                 | Danger
-                 | None
-  deriving (Eq, Show)
-
 -- | Create a new button
 mkButton :: IO Button
 mkButton = do
@@ -160,14 +151,6 @@ triggerClick button = do
   handler <- getClickHandler button
   handler button
 
-instance ToJSON ButtonStyle where
-  toJSON Primary = "primary"
-  toJSON Success = "success"
-  toJSON Info = "info"
-  toJSON Warning = "warning"
-  toJSON Danger = "danger"
-  toJSON None = ""
-
 data ViewName = ButtonWidget
 
 instance ToJSON ViewName where

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

+{-# LANGUAGE OverloadedStrings #-}
+
+module IHaskell.Display.Widgets.Common (
+    -- * Predefined button styles
+    ButtonStyle(..),
+    ) where
+
+import Data.Aeson (ToJSON (..))
+
+-- | 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 = ""

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+module IHaskell.Display.Widgets.String (
+    -- * The String Widgets
+    HTMLWidget,
+    LatexWidget,
+    TextWidget,
+    TextAreaWidget,
+    -- * Create a new button
+    mkButton,
+    -- * Set button properties
+    setStrWidgetButtonStyle,
+    setStrWidgetText,
+    -- * Get button properties
+    getStrWidgetButtonStyle,
+    getStrWidgetText,
+    ) 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           Data.Text (Text)
+import qualified Data.Text as T
+import           System.IO.Unsafe (unsafePerformIO)
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import qualified IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Common (ButtonStyle (..))
+
+data ViewName = HTMLView | LatexView | TextView | TextareaView
+
+data StringWidget =
+       StringWidget
+         { uuid :: U.UUID
+         , strWidgetType :: StrWidgetType
+         , value :: IORef String
+         , description :: IORef Text
+         , disabled :: IORef Bool
+         , placeholder :: IORef String
+         , buttonStyle :: IORef ButtonStyle
+         }
+
+-- | Create a new string widget
+mkStringWidget :: StrWidgetType -> IO StringWidget
+mkStringWidget widgetType = do
+  -- Default properties, with a random uuid
+  commUUID <- U.random
+  wType <- newIORef widgetType
+  val <- newIORef ""
+  desc <- newIORef ""
+  dis <- newIORef False
+  placeholder <- newIORef "Enter your text here..."
+  bst <- newIORef None
+
+  let b = StringWidget
+        { uuid = commUUID
+        , strWidgetType = wType
+        , value = val
+        , description = desc
+        , disabled = dis
+        , buttonStyle = bst
+        }
+
+  let initData = object [ "model_name" .= str "WidgetModel"
+                        , "widget_class" .= getViewName widgetType
+                        ]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen b initData (toJSON b)
+
+  -- Return the string widget
+  return b
+
+-- | 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 :: StringWidget -> [Pair] -> IO ()
+update b v = widgetSendUpdate b . toJSON . object $ v
+
+-- | Modify attributes of a widget, stored inside it as IORefs
+modify :: StringWidget -> (StringWidget -> IORef a) -> a -> IO ()
+modify b attr val = writeIORef (attr b) val
+
+-- | Set the button style
+setStrWidgetButtonStyle :: StringWidget -> ButtonStyle -> IO ()
+setStrWidgetButtonStyle b bst = do
+  modify b buttonStyle bst
+  update b ["button_style" .= bst]
+
+-- | Set the widget text
+setStrWidgetText :: StringWidget -> Text -> IO ()
+setStrWidgetText b txt = do
+  modify b description txt
+  update b ["description" .= txt]
+
+-- | Get the button style
+getStrWidgetButtonStyle :: Button -> IO ButtonStyle
+getStrWidgetButtonStyle = readIORef . buttonStyle
+
+-- | Get the widget text
+getStrWidgetText :: Button -> IO Text
+getStrWidgetText = readIORef . description
+
+instance ToJSON StringWidget where
+  toJSON StringWidget {wType = strWidgetType} =
+    object
+      [ "_view_name" .= toJSON . getViewName $ wType
+      , "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 StringWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget Button where
+  getCommUUID = uuid
+  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
+    when (event == "click") $ triggerClick widget
+
+str :: String -> String
+str = id

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

+{-# LANGUAGE OverloadedStrings #-}
+
+module IHaskell.Display.Widgets.String.HTML (
+    -- * The HTML Widget
+    HTMLWidget,
+    -- * Constructor
+    mkHTMLWidget,
+    -- * Set properties
+    setHTMLValue,
+    -- * Get properties
+    getHTMLValue,
+    ) 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           Data.Text (Text)
+import qualified Data.Text as T
+import           System.IO.Unsafe (unsafePerformIO)
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import qualified IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Common (ButtonStyle (..))
+
+data HTMLWidget =
+       HTMLWidget
+         { uuid :: U.UUID
+         , value :: IORef String
+         }
+
+-- | Create a new HTML widget
+mkHTMLWidget :: IO HTMLWidget
+mkHTMLWidget = do
+  -- Default properties, with a random uuid
+  commUUID <- U.random
+  val <- newIORef ""
+
+  let b = HTMLWidget
+        { uuid = commUUID
+        , value = val
+        }
+
+  let 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)
+
+  -- Return the string widget
+  return b
+
+-- | 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 :: HTMLWidget -> [Pair] -> IO ()
+update b v = widgetSendUpdate b . toJSON . object $ v
+
+-- | Modify attributes stored inside the widget as IORefs
+modify :: HTMLWidget -> (HTMLWidget -> IORef a) -> a -> IO ()
+modify b attr val = writeIORef (attr b) val
+
+-- | Set the HTML string value.
+setHTMLValue :: HTMLWidget -> String -> IO ()
+setHTMLValue b txt = do
+  modify b value txt
+  update b ["value" .= txt]
+
+-- | Get the HTML string value.
+getHTMLValue :: HTMLWidget -> IO String
+getHTMLValue = readIORef . value
+
+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
+
+instance IHaskellDisplay HTMLWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget HTMLWidget where
+  getCommUUID = uuid
+
+str :: String -> String
+str = id

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

+{-# LANGUAGE OverloadedStrings #-}
+
+module IHaskell.Display.Widgets.String.Latex (
+    -- * The Latex Widget
+    LatexWidget,
+    -- * Constructor
+    mkLatexWidget,
+    -- * Set properties
+    setLatexValue,
+    setLatexWidth,
+    -- * Get properties
+    getLatexValue,
+    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           Data.Text (Text)
+import qualified Data.Text as T
+import           System.IO.Unsafe (unsafePerformIO)
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import qualified IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Common (ButtonStyle (..))
+
+data LatexWidget =
+       LatexWidget
+         { uuid :: U.UUID
+         , value :: IORef String
+         , width :: IORef Int
+         }
+
+-- | Create a new Latex widget
+mkLatexWidget :: IO LatexWidget
+mkLatexWidget = do
+  -- Default properties, with a random uuid
+  commUUID <- U.random
+  val <- newIORef ""
+  width <- newIORef 400
+
+  let b = LatexWidget
+        { uuid = commUUID
+        , value = val
+        , width = width
+        }
+
+  let 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)
+
+  -- Return the string widget
+  return b
+
+-- | 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 :: LatexWidget -> [Pair] -> IO ()
+update b v = widgetSendUpdate b . toJSON . object $ v
+
+-- | Modify attributes stored inside the widget as IORefs
+modify :: LatexWidget -> (LatexWidget -> IORef a) -> a -> IO ()
+modify b attr val = writeIORef (attr b) val
+
+-- | Set the Latex string value.
+setLatexValue :: LatexWidget -> String -> IO ()
+setLatexValue b txt = do
+  modify b value txt
+  update b ["value" .= 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 String
+getLatexValue = readIORef . value
+
+-- | 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
+
+instance IHaskellDisplay LatexWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget LatexWidget where
+  getCommUUID = uuid
+
+str :: String -> String
+str = id

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

+{-# LANGUAGE OverloadedStrings #-}
+
+module IHaskell.Display.Widgets.String.Text (
+    -- * The Text Widget
+    TextWidget,
+    -- * Constructor
+    mkTextWidget,
+    -- * Set properties
+    setTextValue,
+    -- * Get properties
+    getTextValue,
+    ) 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           Data.Text (Text)
+import qualified Data.Text as T
+import           System.IO.Unsafe (unsafePerformIO)
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import qualified IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Common (ButtonStyle (..))
+
+data TextWidget =
+       TextWidget
+         { uuid :: U.UUID
+         , value :: IORef String
+         }
+
+-- | Create a new Text widget
+mkTextWidget :: IO TextWidget
+mkTextWidget = do
+  -- Default properties, with a random uuid
+  commUUID <- U.random
+  val <- newIORef ""
+
+  let b = TextWidget
+            { uuid = commUUID
+            , value = val
+            }
+
+  let 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)
+
+  -- Return the string widget
+  return b
+
+-- | 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 :: TextWidget -> [Pair] -> IO ()
+update b v = widgetSendUpdate b . toJSON . object $ v
+
+-- | Modify attributes stored inside the widget as IORefs
+modify :: TextWidget -> (TextWidget -> IORef a) -> a -> IO ()
+modify b attr val = writeIORef (attr b) val
+
+-- | Set the Text string value.
+setTextValue :: TextWidget -> String -> IO ()
+setTextValue b txt = do
+  modify b value txt
+  update b ["value" .= txt]
+
+-- | Get the Text string value.
+getTextValue :: TextWidget -> IO String
+getTextValue = readIORef . value
+
+instance ToJSON TextWidget where
+  toJSON b = object
+               [ "_view_name" .= str "TextView"
+               , "visible" .= True
+               , "_css" .= object []
+               , "msg_throttle" .= (3 :: Int)
+               , "value" .= get value b
+               ]
+    where
+      get x y = unsafePerformIO . readIORef . x $ y
+
+instance IHaskellDisplay TextWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget TextWidget where
+  getCommUUID = uuid
+
+str :: String -> String
+str = id