Added Play widget

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

@@ -71,6 +71,7 @@ library
                        IHaskell.Display.Widgets.Int.BoundedInt.BoundedIntText
                        IHaskell.Display.Widgets.Int.BoundedInt.IntProgress
                        IHaskell.Display.Widgets.Int.BoundedInt.IntSlider
+                       IHaskell.Display.Widgets.Int.BoundedInt.Play
                        IHaskell.Display.Widgets.Int.BoundedIntRange.IntRangeSlider
                        IHaskell.Display.Widgets.Float.FloatText
                        IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText

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

@@ -14,6 +14,7 @@ import           IHaskell.Display.Widgets.Int.IntText as X
 import           IHaskell.Display.Widgets.Int.BoundedInt.BoundedIntText as X
 import           IHaskell.Display.Widgets.Int.BoundedInt.IntProgress as X
 import           IHaskell.Display.Widgets.Int.BoundedInt.IntSlider as X
+import           IHaskell.Display.Widgets.Int.BoundedInt.Play as X
 import           IHaskell.Display.Widgets.Int.BoundedIntRange.IntRangeSlider as X
 
 import           IHaskell.Display.Widgets.Float.FloatText as X

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

@@ -97,6 +97,10 @@ pattern Loop = S.SLoop
 pattern Controls = S.SControls
 pattern Options = S.SOptions
 pattern EnsureOption = S.SEnsureOption
+pattern Playing = S.SPlaying
+pattern Repeat = S.SRepeat
+pattern Interval = S.SInterval
+pattern ShowRepeat = S.SShowRepeat
 
 -- | Close a widget's comm
 closeWidget :: IHaskellWidget w => w -> IO ()

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Int/BoundedInt/Play.hs

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans  #-}
+
+module IHaskell.Display.Widgets.Int.BoundedInt.Play
+  ( -- * The Play Widget
+    Play
+    -- * Constructor
+  , mkPlay
+  ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (void)
+import           Data.Aeson
+import           Data.IORef (newIORef)
+import qualified Data.Scientific as Sci
+import           Data.Vinyl (Rec(..), (<+>))
+
+import           IHaskell.Eval.Widgets
+import           IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display (IHaskellWidget(..))
+import           IHaskell.Display.Widgets.Types
+import           IHaskell.Display.Widgets.Common
+
+-- | 'Play' represents an Play widget from IPython.html.widgets.
+type Play = IPythonWidget 'PlayType
+
+-- | Create a new widget
+mkPlay :: IO Play
+mkPlay = do
+  -- Default properties, with a random uuid
+  wid <- U.random
+
+  let boundedIntAttrs = defaultBoundedIntWidget "PlayView" "PlayModel"
+      playAttrs = (Playing =:: True)
+                  :& (Repeat =:: True)
+                  :& (Interval =:: 100)
+                  :& (StepInt =:: Just 1)
+                  :& (Disabled =:: False)
+                  :& (ShowRepeat =:: True)
+                  :& RNil
+      widgetState = WidgetState $ boundedIntAttrs <+> playAttrs
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget wid stateIO
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget $ toJSON widgetState
+
+  -- Return the widget
+  return widget
+
+instance IHaskellWidget Play where
+  getCommUUID = uuid
+  comm widget val _ =
+    case nestedObjectLookup val ["state", "value"] of
+      Just (Number value) -> do
+        void $ setField' widget IntValue (Sci.coefficient value)
+        triggerChange widget
+      _ -> pure ()

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

@@ -103,5 +103,9 @@ singletons
              | Controls
              | Options
              | EnsureOption
+             | Playing
+             | Repeat
+             | Interval
+             | ShowRepeat
              deriving (Eq, Ord, Show)
   |]

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

@@ -242,6 +242,10 @@ type family FieldType (f :: Field) :: * where
         FieldType 'S.Controls = Bool
         FieldType 'S.Options = [Text]
         FieldType 'S.EnsureOption = Bool
+        FieldType 'S.Playing = Bool
+        FieldType 'S.Repeat = Bool
+        FieldType 'S.Interval = Integer
+        FieldType 'S.ShowRepeat = 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)
@@ -294,6 +298,7 @@ data WidgetType = ButtonType
                 | IntTextType
                 | BoundedIntTextType
                 | IntSliderType
+                | PlayType
                 | IntProgressType
                 | IntRangeSliderType
                 | FloatTextType
@@ -351,6 +356,9 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
   WidgetFields 'IntSliderType =
                   BoundedIntClass :++
                     [ 'S.StepInt, 'S.Orientation, 'S.ReadOut, 'S.ReadOutFormat, 'S.ContinuousUpdate, 'S.Disabled ]
+  WidgetFields 'PlayType =
+                  BoundedIntClass :++
+                    [ 'S.Playing, 'S.Repeat, 'S.Interval, 'S.StepInt, 'S.Disabled, 'S.ShowRepeat ]
   WidgetFields 'IntProgressType =
                   BoundedIntClass :++ ['S.Orientation, 'S.BarStyle]
   WidgetFields 'IntRangeSliderType =
@@ -622,6 +630,18 @@ instance ToPairs (Attr 'S.Options) where
 instance ToPairs (Attr 'S.EnsureOption) where
   toPairs x = ["ensure_option" .= toJSON x]
 
+instance ToPairs (Attr 'S.Playing) where
+  toPairs x = ["playing" .= toJSON x]
+
+instance ToPairs (Attr 'S.Repeat) where
+  toPairs x = ["repeat" .= toJSON x]
+
+instance ToPairs (Attr 'S.Interval) where
+  toPairs x = ["interval" .= toJSON x]
+
+instance ToPairs (Attr 'S.ShowRepeat) where
+  toPairs x = ["show_repeat" .= 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