Add rest of the box widgets

- All widgets complete ✨
- The tutorial will need to be updated.

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

@@ -56,6 +56,9 @@ library
   -- Modules included in this library but not exported.
   other-modules:       IHaskell.Display.Widgets.Button
                        IHaskell.Display.Widgets.Box.Box
+                       IHaskell.Display.Widgets.Box.FlexBox
+                       IHaskell.Display.Widgets.Box.SelectionContainer.Accordion
+                       IHaskell.Display.Widgets.Box.SelectionContainer.Tab
                        IHaskell.Display.Widgets.Bool.CheckBox
                        IHaskell.Display.Widgets.Bool.ToggleButton
                        IHaskell.Display.Widgets.Int.IntText

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

@@ -3,6 +3,9 @@ module IHaskell.Display.Widgets (module X) where
 import           IHaskell.Display.Widgets.Button as X
 
 import           IHaskell.Display.Widgets.Box.Box as X
+import           IHaskell.Display.Widgets.Box.FlexBox as X
+import           IHaskell.Display.Widgets.Box.SelectionContainer.Accordion as X
+import           IHaskell.Display.Widgets.Box.SelectionContainer.Tab as X
 
 import           IHaskell.Display.Widgets.Bool.CheckBox as X
 import           IHaskell.Display.Widgets.Bool.ToggleButton as X

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

@@ -56,10 +56,3 @@ instance IHaskellDisplay Box where
 
 instance IHaskellWidget Box where
   getCommUUID = uuid
-  comm widget (Object dict1) _ = do
-    print dict1
-    -- let key1 = "content" :: Text
-    --     key2 = "event" :: Text
-    --     Just (Object dict2) = HM.lookup key1 dict1
-    --     Just (String event) = HM.lookup key2 dict2
-    -- when (event == "click") $ triggerClick widget

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Box.FlexBox (
+    -- * The FlexBox widget
+    FlexBox,
+    -- * Constructor
+    mkFlexBox,
+    ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+import           Data.Text (Text)
+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 'FlexBox' represents a FlexBox widget from IPython.html.widgets.
+type FlexBox = IPythonWidget FlexBoxType
+
+-- | Create a new box
+mkFlexBox :: IO FlexBox
+mkFlexBox = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+
+  let boxAttrs = defaultBoxWidget "FlexBoxView"
+      flxAttrs = (SOrientation =:: HorizontalOrientation)
+              :& (SFlex =:: 0)
+              :& (SPack =:: StartLocation)
+              :& (SAlign =:: StartLocation)
+              :& RNil
+      widgetState = WidgetState $ boxAttrs <+> flxAttrs
+
+  stateIO <- newIORef widgetState
+
+  let box = IPythonWidget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.FlexBox"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen box initData $ toJSON widgetState
+
+  -- Return the widget
+  return box
+
+instance IHaskellDisplay FlexBox where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget FlexBox where
+  getCommUUID = uuid

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Box/SelectionContainer/Accordion.hs

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Box.SelectionContainer.Accordion (
+    -- * The Accordion widget
+    Accordion,
+    -- * Constructor
+    mkAccordion,
+    ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+import qualified Data.Scientific as Sci
+import           Data.Text (Text)
+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 'Accordion' represents a Accordion widget from IPython.html.widgets.
+type Accordion = IPythonWidget AccordionType
+
+-- | Create a new box
+mkAccordion :: IO Accordion
+mkAccordion = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+
+  let widgetState = WidgetState $ defaultSelectionContainerWidget "AccordionView"
+
+  stateIO <- newIORef widgetState
+
+  let box = IPythonWidget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Accordion"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen box initData $ toJSON widgetState
+
+  -- Return the widget
+  return box
+
+instance IHaskellDisplay Accordion where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget Accordion where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "selected_index" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (Number num) = HM.lookup key2 dict2
+    setField' widget SSelectedIndex (Sci.coefficient num)
+    triggerChange widget

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Box/SelectionContainer/Tab.hs

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Box.SelectionContainer.Tab (
+    -- * The Tab widget
+    TabWidget,
+    -- * Constructor
+    mkTabWidget,
+    ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+import qualified Data.Scientific as Sci
+import           Data.Text (Text)
+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 'TabWidget' represents a Tab widget from IPython.html.widgets.
+type TabWidget = IPythonWidget TabType
+
+-- | Create a new box
+mkTabWidget :: IO TabWidget
+mkTabWidget = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+
+  let widgetState = WidgetState $ defaultSelectionContainerWidget "TabView"
+
+  stateIO <- newIORef widgetState
+
+  let box = IPythonWidget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Tab"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen box initData $ toJSON widgetState
+
+  -- Return the widget
+  return box
+
+instance IHaskellDisplay TabWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget TabWidget where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "selected_index" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (Number num) = HM.lookup key2 dict2
+    setField' widget SSelectedIndex (Sci.coefficient num)
+    triggerChange widget

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

@@ -82,6 +82,11 @@ singletons [d|
              | OverflowX
              | OverflowY
              | BoxStyle
+             | Flex
+             | Pack
+             | Align
+             | Titles
+             | SelectedIndex
              deriving (Eq, Ord, Show)
              |]
 
@@ -238,3 +243,16 @@ instance ToJSON BoxStyleValue where
   toJSON WarningBox = "warning"
   toJSON DangerBox = "danger"
   toJSON DefaultBox = ""
+
+data LocationValue = StartLocation
+                   | CenterLocation
+                   | EndLocation
+                   | BaselineLocation
+                   | StretchLocation
+
+instance ToJSON LocationValue where
+  toJSON StartLocation = "start"
+  toJSON CenterLocation = "center"
+  toJSON EndLocation = "end"
+  toJSON BaselineLocation = "baseline"
+  toJSON StretchLocation = "stretch"

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

@@ -46,6 +46,9 @@ module IHaskell.Display.Widgets.Types where
 -- numeric values is ignored by the frontend and the default value is used instead. Some numbers need to
 -- be sent as numbers (represented by @Integer@), whereas some need to be sent as Strings (@StrInt@).
 --
+-- Child widgets are expected to be sent as strings of the form "IPY_MODEL_<uuid>", where @<uuid>@
+-- represents the uuid of the widget's comm.
+--
 -- To know more about the IPython messaging specification (as implemented in this package) take a look
 -- at the supplied MsgSpec.md.
 
@@ -94,6 +97,7 @@ type BoundedFloatClass = FloatClass :++ '[StepFloat, MinFloat, MaxFloat]
 type FloatRangeClass = FloatClass :++ '[FloatPairValue, LowerFloat, UpperFloat]
 type BoundedFloatRangeClass = FloatRangeClass :++ '[StepFloat, MinFloat, MaxFloat]
 type BoxClass = DOMWidgetClass :++ '[Children, OverflowX, OverflowY, BoxStyle]
+type SelectionContainerClass = BoxClass :++ '[Titles, SelectedIndex, ChangeHandler]
 
 -- Types associated with Fields.
 type family FieldType (f :: Field) :: * where
@@ -163,6 +167,11 @@ type family FieldType (f :: Field) :: * where
   FieldType OverflowX = OverflowValue
   FieldType OverflowY = OverflowValue
   FieldType BoxStyle = BoxStyleValue
+  FieldType Flex = Int
+  FieldType Pack = LocationValue
+  FieldType Align = LocationValue
+  FieldType Titles = [Text]
+  FieldType SelectedIndex = Integer
 
 -- | 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)
@@ -216,6 +225,8 @@ data WidgetType = ButtonType
                 | FloatRangeSliderType
                 | BoxType
                 | FlexBoxType
+                | AccordionType
+                | TabType
 
 -- Fields associated with a widget
 type family WidgetFields (w :: WidgetType) :: [Field] where
@@ -244,7 +255,9 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
   WidgetFields FloatProgressType = BoundedFloatClass :++ '[BarStyle]
   WidgetFields FloatRangeSliderType = BoundedFloatRangeClass :++ '[Orientation, ShowRange, ReadOut, SliderColor]
   WidgetFields BoxType = BoxClass
-  WidgetFields FlexBoxType = BoxClass
+  WidgetFields FlexBoxType = BoxClass :++ '[Orientation, Flex, Pack, Align]
+  WidgetFields AccordionType = SelectionContainerClass
+  WidgetFields TabType = SelectionContainerClass
 
 -- Wrapper around a field's value. A dummy value is sent as an empty string to the frontend.
 data AttrVal a = Dummy a | Real a
@@ -341,6 +354,11 @@ instance ToPairs (Attr Children) where toPairs x = ["children" .= toJSON x]
 instance ToPairs (Attr OverflowX) where toPairs x = ["overflow_x" .= toJSON x]
 instance ToPairs (Attr OverflowY) where toPairs x = ["overflow_y" .= toJSON x]
 instance ToPairs (Attr BoxStyle) where toPairs x = ["box_style" .= toJSON x]
+instance ToPairs (Attr Flex) where toPairs x = ["flex" .= toJSON x]
+instance ToPairs (Attr Pack) where toPairs x = ["pack" .= toJSON x]
+instance ToPairs (Attr Align) where toPairs x = ["align" .= toJSON x]
+instance ToPairs (Attr Titles) where toPairs x = ["_titles" .= toJSON x]
+instance ToPairs (Attr SelectedIndex) where toPairs x = ["selected_index" .= toJSON x]
 
 -- | Store the value for a field, as an object parametrized by the Field. No verification is done
 -- for these values.
@@ -508,6 +526,7 @@ defaultBoundedFloatRangeWidget viewName = defaultFloatRangeWidget viewName <+> b
                               :& (SMaxFloat =:: 100)
                               :& RNil
 
+-- | A record representing a widget of the _Box class from IPython
 defaultBoxWidget :: FieldType ViewName -> Rec Attr BoxClass
 defaultBoxWidget viewName = defaultDOMWidget viewName <+> boxAttrs
   where boxAttrs = (SChildren =:: [])
@@ -516,6 +535,14 @@ defaultBoxWidget viewName = defaultDOMWidget viewName <+> boxAttrs
                 :& (SBoxStyle =:: DefaultBox)
                 :& RNil
 
+-- | A record representing a widget of the _SelectionContainer class from IPython
+defaultSelectionContainerWidget :: FieldType ViewName -> Rec Attr SelectionContainerClass
+defaultSelectionContainerWidget viewName = defaultBoxWidget viewName <+> selAttrs
+  where selAttrs = (STitles =:: [])
+                :& (SSelectedIndex =:: 0)
+                :& (SChangeHandler =:: return ())
+                :& RNil
+
 newtype WidgetState w = WidgetState { _getState :: Rec Attr (WidgetFields w) }
 
 -- All records with ToPair instances for their Attrs will automatically have a toJSON instance now.