mirrors/IHaskell
1
0
Fork 0
mirror of https://github.com/IHaskell/IHaskell.git synced 2025-04-19 12:56:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

Add rest of the box widgets

Browse Source 
- All widgets complete ✨
- The tutorial will need to be updated.
This commit is contained in:
Sumit Sahrawat 2015-07-14 08:05:19 +05:30
parent bcbeddc131
commit b87b09274f
8 changed files with 248 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
ihaskell-display/ihaskell-widgets/ihaskell-widgets.cabal
View File

@ -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

3
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets.hs
View File

@ -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

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

@ -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

64
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Box/FlexBox.hs Normal file
View File

@ -0,0 +1,64 @@
{-# 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

66
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Box/SelectionContainer/Accordion.hs Normal file
View File

@ -0,0 +1,66 @@
{-# 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

66
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Box/SelectionContainer/Tab.hs Normal file
View File

@ -0,0 +1,66 @@
{-# 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

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

@ -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"

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

@ -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.