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

Numeric float widgets

Browse Source
This commit is contained in:
David Davó 2021-07-12 12:01:58 +02:00
parent 3f363ac842
commit cb13bfccb9
10 changed files with 82 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -76,6 +76,7 @@ library
IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText
IHaskell.Display.Widgets.Float.BoundedFloat.FloatProgress
IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider
IHaskell.Display.Widgets.Float.BoundedFloat.FloatLogSlider
IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider
IHaskell.Display.Widgets.Image
IHaskell.Display.Widgets.Output

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

@ -20,6 +20,7 @@ import IHaskell.Display.Widgets.Float.FloatText as X
import IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText as X
import IHaskell.Display.Widgets.Float.BoundedFloat.FloatProgress as X
import IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider as X
import IHaskell.Display.Widgets.Float.BoundedFloat.FloatLogSlider as X
import IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider as X
import IHaskell.Display.Widgets.Image as X

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

@ -82,6 +82,7 @@ pattern FloatPairValue = S.SFloatPairValue
pattern LowerFloat = S.SLowerFloat
pattern UpperFloat = S.SUpperFloat
pattern Orientation = S.SOrientation
pattern BaseFloat = S.SBaseFloat
pattern ShowRange = S.SShowRange
pattern ReadOut = S.SReadOut
pattern SliderColor = S.SSliderColor

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

@ -36,7 +36,7 @@ mkBoundedFloatText = do
-- Default properties, with a random uuid
wid <- U.random
let widgetState = WidgetState $ defaultBoundedFloatWidget "FloatTextView" "FloatTextModel"
let widgetState = WidgetState $ defaultBoundedFloatWidget "FloatTextView" "BoundedFloatTextModel"
stateIO <- newIORef widgetState

66
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatLogSlider.hs Normal file
View File

@ -0,0 +1,66 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module IHaskell.Display.Widgets.Float.BoundedFloat.FloatLogSlider
( -- * The FloatSlider Widget
FloatLogSlider
-- * Constructor
, mkFloatLogSlider
) 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
-- | 'FloatLogSlider' represents an FloatLogSlider widget from IPython.html.widgets.
type FloatLogSlider = IPythonWidget 'FloatLogSliderType
-- | Create a new widget
mkFloatLogSlider :: IO FloatLogSlider
mkFloatLogSlider = do
-- Default properties, with a random uuid
wid <- U.random
let boundedFloatAttrs = defaultBoundedFloatWidget "FloatLogSliderView" "FloatLogSliderModel"
sliderAttrs = (Orientation =:: HorizontalOrientation)
:& (ShowRange =:: False)
:& (ReadOut =:: True)
:& (SliderColor =:: "")
:& (BaseFloat =:: 10.0)
:& RNil
widgetState = WidgetState $ boundedFloatAttrs <+> sliderAttrs
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 FloatLogSlider where
getCommUUID = uuid
comm widget val _ =
case nestedObjectLookup val ["state", "value"] of
Just (Number value) -> do
void $ setField' widget FloatValue (Sci.toRealFloat value)
triggerChange widget
_ -> pure ()

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

@ -35,7 +35,7 @@ mkFloatProgress = do
-- Default properties, with a random uuid
wid <- U.random
let boundedFloatAttrs = defaultBoundedFloatWidget "ProgressView" "ProgressModel"
let boundedFloatAttrs = defaultBoundedFloatWidget "ProgressView" "FloatProgressModel"
progressAttrs = (Orientation =:: HorizontalOrientation)
:& (BarStyle =:: DefaultBar)
:& RNil

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

@ -38,7 +38,7 @@ mkFloatRangeSlider = do
-- Default properties, with a random uuid
wid <- U.random
let boundedFloatAttrs = defaultBoundedFloatRangeWidget "FloatSliderView" "FloatSliderModel"
let boundedFloatAttrs = defaultBoundedFloatRangeWidget "FloatRangeSliderView" "FloatRangeSliderModel"
sliderAttrs = (Orientation =:: HorizontalOrientation)
:& (ShowRange =:: True)
:& (ReadOut =:: True)

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

@ -36,7 +36,7 @@ mkBoundedIntText = do
-- Default properties, with a random uuid
wid <- U.random
let widgetState = WidgetState $ defaultBoundedIntWidget "IntTextView" "IntTextModel"
let widgetState = WidgetState $ defaultBoundedIntWidget "IntTextView" "BoundedIntTextModel"
stateIO <- newIORef widgetState

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

@ -88,6 +88,7 @@ singletons
| LowerFloat
| UpperFloat
| Orientation
| BaseFloat
| ShowRange
| ReadOut
| SliderColor

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

@ -215,6 +215,7 @@ type family FieldType (f :: Field) :: * where
FieldType 'S.UpperInt = Integer
FieldType 'S.IntPairValue = (Integer, Integer)
FieldType 'S.Orientation = OrientationValue
FieldType 'S.BaseFloat = Double
FieldType 'S.ShowRange = Bool
FieldType 'S.ReadOut = Bool
FieldType 'S.SliderColor = Text
@ -289,6 +290,7 @@ data WidgetType = ButtonType
| FloatTextType
| BoundedFloatTextType
| FloatSliderType
| FloatLogSliderType
| FloatProgressType
| FloatRangeSliderType
| BoxType
@ -341,6 +343,9 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
WidgetFields 'FloatSliderType =
BoundedFloatClass :++
['S.Orientation, 'S.ShowRange, 'S.ReadOut, 'S.SliderColor]
WidgetFields 'FloatLogSliderType =
BoundedFloatClass :++
['S.Orientation, 'S.ShowRange, 'S.ReadOut, 'S.SliderColor, 'S.BaseFloat]
WidgetFields 'FloatProgressType =
BoundedFloatClass :++ ['S.Orientation, 'S.BarStyle]
WidgetFields 'FloatRangeSliderType =
@ -557,6 +562,9 @@ instance ToPairs (Attr 'S.UpperFloat) where
instance ToPairs (Attr 'S.Orientation) where
toPairs x = ["orientation" .= toJSON x]
instance ToPairs (Attr 'S.BaseFloat) where
toPairs x = ["base" .= toJSON x]
instance ToPairs (Attr 'S.ShowRange) where
toPairs x = ["_range" .= toJSON x]