Added colorpicker widget

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

@@ -61,6 +61,7 @@ library
 
   -- Modules included in this library but not exported.
   other-modules:       IHaskell.Display.Widgets.Button
+                       IHaskell.Display.Widgets.ColorPicker
                        IHaskell.Display.Widgets.Box.Box
                        IHaskell.Display.Widgets.Box.SelectionContainer.Accordion
                        IHaskell.Display.Widgets.Box.SelectionContainer.Tab

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

@@ -1,6 +1,7 @@
 module IHaskell.Display.Widgets (module X) where
 
 import           IHaskell.Display.Widgets.Button as X
+import           IHaskell.Display.Widgets.ColorPicker as X
 
 import           IHaskell.Display.Widgets.Box.Box as X
 import           IHaskell.Display.Widgets.Box.SelectionContainer.Accordion as X

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

@@ -0,0 +1,56 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans  #-}
+
+module IHaskell.Display.Widgets.ColorPicker
+  ( -- * The ColorPicker Widget
+    ColorPicker
+    -- * Create a new ColorPicker
+  , mkColorPicker
+  ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Data.Aeson
+import           Data.IORef (newIORef)
+import           Data.Vinyl (Rec(..), (<+>))
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import           IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Types
+import           IHaskell.Display.Widgets.Common
+
+-- | A 'ColorPicker' represents a ColorPicker from IPython.html.widgets.
+type ColorPicker = IPythonWidget 'ColorPickerType
+
+-- | Create a new ColorPicker
+mkColorPicker :: IO ColorPicker
+mkColorPicker = do
+  -- Default properties, with a random uuid
+  wid <- U.random
+
+  let ddw = defaultDescriptionWidget "ColorPickerView" "ColorPickerModel"
+      color = (StringValue =:: "black")
+              :& (Concise =:: False)
+              :& (Disabled =:: False)
+              :& RNil
+      colorPickerState = WidgetState (ddw <+> color)
+
+  stateIO <- newIORef colorPickerState
+
+  let colorPicker = IPythonWidget wid stateIO
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen colorPicker $ toJSON colorPickerState
+
+  -- Return the ColorPicker widget
+  return colorPicker
+
+instance IHaskellWidget ColorPicker where
+  getCommUUID = uuid

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

@@ -101,6 +101,7 @@ pattern Playing = S.SPlaying
 pattern Repeat = S.SRepeat
 pattern Interval = S.SInterval
 pattern ShowRepeat = S.SShowRepeat
+pattern Concise = S.SConcise
 
 -- | Close a widget's comm
 closeWidget :: IHaskellWidget w => w -> IO ()

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

@@ -107,5 +107,6 @@ singletons
              | Repeat
              | Interval
              | ShowRepeat
+             | Concise
              deriving (Eq, Ord, Show)
   |]

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

@@ -246,6 +246,7 @@ type family FieldType (f :: Field) :: * where
         FieldType 'S.Repeat = Bool
         FieldType 'S.Interval = Integer
         FieldType 'S.ShowRepeat = Bool
+        FieldType 'S.Concise = Bool
 
 -- | Can be used to put different widgets in a list. Useful for dealing with children widgets.
 data ChildWidget = forall w. RecAll Attr (WidgetFields w) ToPairs => ChildWidget (IPythonWidget w)
@@ -274,6 +275,7 @@ instance CustomBounded Double where
 
 -- Different types of widgets. Every widget in IPython has a corresponding WidgetType
 data WidgetType = ButtonType
+                | ColorPickerType
                 | AudioType
                 | ImageType
                 | VideoType
@@ -318,6 +320,10 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
                   DescriptionWidgetClass :++
                     ['S.Disabled, 'S.Icon, 'S.ButtonStyle ,'S.ClickHandler]
 
+  WidgetFields 'ColorPickerType =
+                  DescriptionWidgetClass :++
+                    ['S.StringValue, 'S.Concise, 'S.Disabled]
+
   WidgetFields 'AudioType =
                   MediaClass :++ ['S.AudioFormat, 'S.AutoPlay, 'S.Loop, 'S.Controls]
   WidgetFields 'ImageType =
@@ -642,6 +648,9 @@ instance ToPairs (Attr 'S.Interval) where
 instance ToPairs (Attr 'S.ShowRepeat) where
   toPairs x = ["show_repeat" .= toJSON x]
 
+instance ToPairs (Attr 'S.Concise) where
+  toPairs x = ["concise" .= toJSON x]
+
 -- | Store the value for a field, as an object parametrized by the Field. No verification is done
 -- for these values.
 (=::) :: (SingI f, Typeable (FieldType f)) => Sing f -> FieldType f -> Attr f