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

Added Selection Sliders widgets

Browse Source
This commit is contained in:
David Davó 2021-07-13 11:58:01 +02:00
parent 3af859323e
commit 7e20685cd5
6 changed files with 131 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -83,6 +83,8 @@ library
IHaskell.Display.Widgets.Selection.Dropdown
IHaskell.Display.Widgets.Selection.RadioButtons
IHaskell.Display.Widgets.Selection.Select
IHaskell.Display.Widgets.Selection.SelectionSlider
IHaskell.Display.Widgets.Selection.SelectionRangeSlider
IHaskell.Display.Widgets.Selection.ToggleButtons
IHaskell.Display.Widgets.Selection.SelectMultiple
IHaskell.Display.Widgets.String.HTML

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

@ -30,6 +30,8 @@ import IHaskell.Display.Widgets.Output as X
import IHaskell.Display.Widgets.Selection.Dropdown as X
import IHaskell.Display.Widgets.Selection.RadioButtons as X
import IHaskell.Display.Widgets.Selection.Select as X
import IHaskell.Display.Widgets.Selection.SelectionSlider as X
import IHaskell.Display.Widgets.Selection.SelectionRangeSlider as X
import IHaskell.Display.Widgets.Selection.ToggleButtons as X
import IHaskell.Display.Widgets.Selection.SelectMultiple as X

62
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/SelectionRangeSlider.hs Normal file
View File

@ -0,0 +1,62 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module IHaskell.Display.Widgets.Selection.SelectionRangeSlider
( -- * The SelectionRangeSlider Widget
SelectionRangeSlider
-- * Constructor
, mkSelectionRangeSlider
) 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 qualified Data.Vector as V
import Data.Vinyl (Rec(..), (<+>), rput)
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 'SelectionRangeSlider' represents a SelectionSlider widget from IPyhon.widgets
type SelectionRangeSlider = IPythonWidget 'SelectionRangeSliderType
-- | Create a new SelectionRangeSlider widget
mkSelectionRangeSlider :: IO SelectionRangeSlider
mkSelectionRangeSlider = do
wid <- U.random
let selectionAttrs = defaultMultipleSelectionWidget "SelectionRangeSliderView" "SelectionRangeSliderModel"
widgetState = WidgetState $ rput (Indices =:: [0,0]) $ selectionAttrs <+>
(Orientation =:: HorizontalOrientation)
:& RNil
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 created widget
return widget
instance IHaskellWidget SelectionRangeSlider where
getCommUUID = uuid
comm widget val _ =
case nestedObjectLookup val ["state", "index"] of
Just (Array indices) -> do
let indicesList = map (\(Number x) -> Sci.coefficient x) $ V.toList indices
void $ setField' widget Indices indicesList
triggerSelection widget
_ -> pure ()

60
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/SelectionSlider.hs Normal file
View File

@ -0,0 +1,60 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module IHaskell.Display.Widgets.Selection.SelectionSlider
( -- * The SelectionSlider Widget
SelectionSlider
-- * Constructor
, mkSelectionSlider
) 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.Display
import IHaskell.Eval.Widgets
import IHaskell.IPython.Message.UUID as U
import IHaskell.Display.Widgets.Types
import IHaskell.Display.Widgets.Common
-- | A 'SelectionSlider' represents a SelectionSlider widget from IPyhon.widgets
type SelectionSlider = IPythonWidget 'SelectionSliderType
-- | Create a new SelectionSLider widget
mkSelectionSlider :: IO SelectionSlider
mkSelectionSlider = do
wid <- U.random
let selectionAttrs = defaultSelectionWidget "SelectionSliderView" "SelectionSliderModel"
widgetState = WidgetState $ selectionAttrs <+>
(Orientation =:: HorizontalOrientation)
:& RNil
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 created widget
return widget
instance IHaskellWidget SelectionSlider where
getCommUUID = uuid
comm widget val _ =
case nestedObjectLookup val ["state", "index"] of
Just (Number index) -> do
void $ setField' widget Index (Sci.coefficient index)
triggerSelection widget
_ -> pure ()

2
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/HTMLMath.hs
View File

@ -6,7 +6,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module IHaskell.Display.Widgets.String.HTMLMath
( -- * The HTML Widget
( -- * The HTMLMath Widget
HTMLMathWidget
-- * Constructor
, mkHTMLMathWidget

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

@ -281,6 +281,8 @@ data WidgetType = ButtonType
| DropdownType
| RadioButtonsType
| SelectType
| SelectionSliderType
| SelectionRangeSliderType
| ToggleButtonsType
| SelectMultipleType
| IntTextType
@ -327,6 +329,8 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
WidgetFields 'DropdownType = SelectionClass :++ '[ 'S.ButtonStyle]
WidgetFields 'RadioButtonsType = SelectionClass
WidgetFields 'SelectType = SelectionClass
WidgetFields 'SelectionSliderType = SelectionClass :++ '[ 'S.Orientation ]
WidgetFields 'SelectionRangeSliderType = MultipleSelectionClass :++ '[ 'S.Orientation ]
WidgetFields 'ToggleButtonsType =
SelectionClass :++ ['S.Tooltips, 'S.Icons, 'S.ButtonStyle]
WidgetFields 'SelectMultipleType = MultipleSelectionClass