Minimal implementation of Buttons

ihaskell-display/ihaskell-widgets/LICENSE

+Copyright (c) 2015 Sumit Sahrawat
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

ihaskell-display/ihaskell-widgets/Setup.hs

+import Distribution.Simple
+main = defaultMain

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

+-- 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) 
+-- 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.1.0.0
+
+-- A short (one-line) description of the package.
+synopsis:            IPython standard widgets for IHaskell.
+
+-- A longer description of the package.
+-- description:         
+
+-- URL for the project homepage or repository.
+homepage:            http://www.github.com/gibiansky/IHaskell
+
+-- The license under which the package is released.
+license:             MIT
+
+-- The file containing the license text.
+license-file:        LICENSE
+
+-- The package author(s).
+author:              Sumit Sahrawat
+
+-- 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:           
+
+-- category:            
+
+build-type:          Simple
+
+-- Extra files to be distributed with the package, such as examples or a 
+-- README.
+-- extra-source-files:  
+
+-- Constraint on the version of Cabal needed to build this package.
+cabal-version:       >=1.10
+
+library
+  -- Modules exported by the library.
+  exposed-modules:     IHaskell.Display.Widgets
+  
+  -- Modules included in this library but not exported.
+  other-modules:       IHaskell.Display.Widgets.Button
+  
+  -- LANGUAGE extensions used by modules in this package.
+  -- other-extensions:    
+  
+  -- Other library packages from which modules are imported.
+  build-depends:       aeson >= 0.8.1.0
+                     , base >=4.7 && <4.9
+                     , ipython-kernel >= 0.6.1.0
+                     , text >= 1.2.1.0
+                     , unordered-containers >= 0.2.5.1
+
+                       -- Waiting for the next release
+                     , ihaskell -any
+
+  -- Directories containing source files.
+  hs-source-dirs:      src
+  
+  -- Base language which the package is written in.
+  default-language:    Haskell2010
+  

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

+module IHaskell.Display.Widgets
+       ( module IHaskell.Display.Widgets.Button
+       ) where
+
+import IHaskell.Display.Widgets.Button

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module IHaskell.Display.Widgets.Button where
+
+import           Prelude
+
+import           Control.Monad                 (when)
+import           Data.Aeson                    (ToJSON, Value (..), object,
+                                                toJSON, (.=))
+import           Data.HashMap.Strict           as Map
+import           Data.IORef
+import           Data.Text                     (Text)
+import qualified Data.Text                     as T
+import           IHaskell.Display
+import qualified IHaskell.IPython.Message.UUID as U
+import           IHaskell.Eval.Widgets
+import           IHaskell.Types (WidgetMethod (..))
+import           System.IO.Unsafe              (unsafePerformIO)
+
+-- | ADT for a button
+data Button = Button { uuid        :: U.UUID
+                     , description :: IORef Text
+                     , tooltip     :: IORef Text
+                     , disabled    :: IORef Bool
+                     , buttonStyle :: IORef ButtonStyle
+                     }
+
+-- | Pre-defined button-styles
+data ButtonStyle = Primary | Success | Info | Warning | Danger | None
+
+-- | Create a new button
+mkButton :: IO Button
+mkButton = do
+  -- Default properties, with a random uuid
+  uuid   <- U.random
+  sender <- newIORef Nothing
+  desc   <- newIORef ""
+  ttip   <- newIORef ""
+  dis    <- newIORef False
+  sty    <- newIORef None
+
+  let b = Button uuid desc ttip dis sty
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen b $ toJSON ButtonInitData
+
+  -- Initial state update
+  widgetSendUpdate b . toJSON . UpdateState . toJSON $ b
+
+  -- REMOVE ME: Let's display it too
+  widgetSendView b
+
+  -- Return the button widget
+  return b
+
+-- send :: Button -> Value -> IO ()
+-- send b v = widgetSendData (uuid b) v
+
+-- -- | Set the button style
+-- setButtonStyle :: ButtonStyle -> Button -> IO ()
+-- setButtonStyle bst b = do
+--   modifyIORef (buttonStyle b) (const bst)
+--   send b . toJSON $ UpdateState b
+
+-- -- | Set the button label
+-- setButtonLabel :: Text -> Button -> IO ()
+-- setButtonLabel txt b = do
+--   modifyIORef (description b) (const txt)
+--   send b . toJSON $ UpdateState b
+
+-- -- | Set the button tooltip
+-- setButtonTooltip :: Text -> Button -> IO ()
+-- setButtonTooltip txt b = do
+--   modifyIORef (tooltip b) (const txt)
+--   send b . toJSON $ UpdateState b
+
+-- -- | Disable the button
+-- disableButton :: Button -> IO ()
+-- disableButton b = do
+--   modifyIORef (disabled b) (const True)
+--   send b . toJSON $ UpdateState b
+
+-- -- | Enable the button
+-- enableButton :: Button -> IO ()
+-- enableButton b = do
+--   modifyIORef (disabled b) (const False)
+--   send b . toJSON $ UpdateState b
+
+-- -- | Toggle the button
+-- toggleButtonStatus :: Button -> IO ()
+-- toggleButtonStatus b = do
+--   modifyIORef (disabled b) not
+--   send b . toJSON $ UpdateState b
+
+-- -- | Get the button style
+-- getButtonStyle :: Button -> IO ButtonStyle
+-- getButtonStyle = readIORef . buttonStyle
+
+-- -- | Get the button text
+-- getButtonText :: Button -> IO Text
+-- getButtonText = readIORef . description
+
+-- -- | Get the button tooltip
+-- getButtonTooltip :: Button -> IO Text
+-- getButtonTooltip = readIORef . tooltip
+
+instance ToJSON ButtonStyle where
+  toJSON Primary = "primary"
+  toJSON Success = "success"
+  toJSON Info    = "info"
+  toJSON Warning = "warning"
+  toJSON Danger  = "danger"
+  toJSON None    = ""
+
+--------------------------------------------------------------------------------
+-- To be separated out to another module
+
+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
+
+instance IHaskellDisplay Button where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget Button where
+  -- open widget sender = do
+  --   sender . toJSON $ UpdateState widget
+  -- comm widget (Object dict1) publisher = 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") $ do
+  --     modifyIORef (description widget) (flip T.append ";")
+  --     publisher . toJSON $ UpdateState widget
+
+str :: String -> String
+str = id

src/IHaskell/Eval/Evaluate.hs

@@ -82,6 +82,7 @@ import           IHaskell.Eval.Lint
 import           IHaskell.Display
 import qualified IHaskell.Eval.Hoogle as Hoogle
 import           IHaskell.Eval.Util
+import           IHaskell.Eval.Widgets
 import           IHaskell.BrokenPackages
 import qualified IHaskell.IPython.Message.UUID as UUID
 import           IHaskell.Eval.Widgets

src/IHaskell/Eval/Widgets.hs

@@ -3,6 +3,7 @@ module IHaskell.Eval.Widgets
        , widgetSendUpdate
        , widgetSendView
        , widgetSendClose
+       , relayWidgetMessages
        ) where
 
 import IHaskellPrelude