Add dropdown widget

- Add dropdown widget and some functions to manipulate it
- Requires the ability to update the internal stored widget without
  sending a message to the frontend.

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

@@ -56,6 +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.String.HTML
                        IHaskell.Display.Widgets.String.Latex
                        IHaskell.Display.Widgets.String.Text
@@ -63,7 +64,7 @@ library
                        IHaskell.Display.Widgets.Output
 
                        IHaskell.Display.Widgets.Common
-  
+
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions:    
   
@@ -77,6 +78,9 @@ library
                        -- Waiting for the next release
                      , ihaskell -any
 
+                       -- DEBUG: Remove Me
+                     , aeson-pretty -any
+
   -- Directories containing source files.
   hs-source-dirs:      src
   

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

@@ -2,6 +2,8 @@ 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.Image as X
 
 import           IHaskell.Display.Widgets.String.HTML as X

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

@@ -0,0 +1,143 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module IHaskell.Display.Widgets.Dropdown 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.Aeson.Encode.Pretty (encodePretty)
+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.Types (WidgetMethod(..))
+
+-- | A 'Dropdown' represents a Dropdown widget from IPython.html.widgets.
+data Dropdown =
+       Dropdown
+         { uuid :: U.UUID       -- ^ The UUID for the comm
+         , description :: IORef Text -- ^ The label displayed beside the dropdown
+         , disabled :: IORef Bool    -- ^ Whether the dropdown is disabled
+         , selectedLabel :: IORef Text -- ^ The label which is currently selected
+         , labelOptions :: IORef [Text] -- ^ The possible label options
+         }
+
+-- | Create a new dropdown
+mkDropdown :: IO Dropdown
+mkDropdown = do
+  -- Default properties, with a random uuid
+  commUUID <- U.random
+  desc <- newIORef ""
+  dis <- newIORef False
+  sel <- newIORef ""
+  opts <- newIORef []
+
+  let b = Dropdown
+        { uuid = commUUID
+        , description = desc
+        , disabled = dis
+        , selectedLabel = sel
+        , labelOptions = opts
+        }
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen b (toJSON DropdownInitData) (toJSON b)
+
+  -- Return the dropdown widget
+  return b
+
+-- | Send an update msg with custom json. Make it easy to update fragments of the
+-- state, by accepting Pairs instead of a Value.
+update :: Dropdown -> [Pair] -> IO ()
+update b v = widgetSendUpdate b . toJSON . object $ v
+
+-- | Modify attributes of a dropdown, stored inside it as IORefs
+modify :: Dropdown -> (Dropdown -> IORef a) -> a -> IO ()
+modify d attr val = writeIORef (attr d) val
+
+setDropdownText :: Dropdown -> Text -> IO ()
+setDropdownText widget text = do
+  modify widget description text
+  update widget ["description" .= text]
+
+setDropdownStatus :: Dropdown -> Bool -> IO ()
+setDropdownStatus widget stat = do
+  let newStat = not stat
+  modify widget disabled newStat
+  update widget ["disabled" .= newStat]
+
+setDropdownOptions :: Dropdown -> [Text] -> IO ()
+setDropdownOptions widget opts = do
+  modify widget labelOptions opts
+  update widget ["_options_labels" .= opts]
+
+setDropdownSelected :: Dropdown -> Text -> IO ()
+setDropdownSelected widget opt = do
+  possibleOpts <- getDropdownOptions widget
+  when (opt `elem` possibleOpts) $ do
+    modify widget selectedLabel opt
+    update widget ["selected_label" .= opt]
+
+toggleDropdownStatus :: Dropdown -> IO ()
+toggleDropdownStatus widget = modifyIORef (disabled widget) not
+
+getDropdownText :: Dropdown -> IO Text
+getDropdownText = readIORef . description
+
+getDropdownStatus :: Dropdown -> IO Bool
+getDropdownStatus = fmap not . readIORef . disabled
+
+getDropdownOptions :: Dropdown -> IO [Text]
+getDropdownOptions = readIORef . labelOptions
+
+getDropdownSelected :: Dropdown -> IO Text
+getDropdownSelected = readIORef . selectedLabel
+
+data ViewName = DropdownWidget
+
+instance ToJSON ViewName where
+  toJSON DropdownWidget = "DropdownView"
+
+data InitData = DropdownInitData
+
+instance ToJSON InitData where
+  toJSON DropdownInitData = object
+                            [ "model_name" .= str "WidgetModel"
+                            , "widget_class" .= str "IPython.Dropdown"
+                            ]
+
+instance ToJSON Dropdown where
+  toJSON b = object
+               [ "_view_name" .= toJSON DropdownWidget
+               , "visible" .= True
+               , "_css" .= object []
+               , "msg_throttle" .= (3 :: Int)
+               , "disabled" .= get disabled b
+               , "description" .= get description b
+               , "_options_labels" .= get labelOptions b
+               , "selected_label" .= get selectedLabel b
+               , "button_style" .= str ""
+               ]
+    where
+      get x y = unsafePerformIO . readIORef . x $ y
+
+instance IHaskellDisplay Dropdown where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget Dropdown where
+  getCommUUID = uuid
+  comm widget msg _ = putStrLn . show . encodePretty $ msg
+
+str :: String -> String
+str = id