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

Select widgets

Browse Source
This commit is contained in:
David Davó 2021-07-07 17:25:32 +02:00
parent 362bef6ee4
commit dff65fffdf
9 changed files with 36 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -62,13 +62,11 @@ pattern B64Value = S.SB64Value
pattern ImageFormat = S.SImageFormat
pattern BoolValue = S.SBoolValue
pattern Options = S.SOptions
pattern SelectedLabel = S.SSelectedLabel
pattern SelectedValue = S.SSelectedValue
pattern Index = S.SIndex
pattern SelectionHandler = S.SSelectionHandler
pattern Tooltips = S.STooltips
pattern Icons = S.SIcons
pattern SelectedLabels = S.SSelectedLabels
pattern SelectedValues = S.SSelectedValues
pattern Indices = S.SIndices
pattern IntValue = S.SIntValue
pattern StepInt = S.SStepInt
pattern MaxInt = S.SMaxInt

17
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/Dropdown.hs
View File

@ -18,6 +18,7 @@ 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
@ -52,18 +53,8 @@ mkDropdown = do
instance IHaskellWidget Dropdown where
getCommUUID = uuid
comm widget val _ =
case nestedObjectLookup val ["sync_data", "selected_label"] of
Just (String label) -> do
opts <- getField widget Options
case opts of
OptionLabels _ -> do
void $ setField' widget SelectedLabel label
void $ setField' widget SelectedValue label
OptionDict ps ->
case lookup label ps of
Nothing -> return ()
Just value -> do
void $ setField' widget SelectedLabel label
void $ setField' widget SelectedValue value
case nestedObjectLookup val ["state", "index"] of
Just (Number index) -> do
void $ setField' widget Index (Sci.coefficient index)
triggerSelection widget
_ -> pure ()

17
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/RadioButtons.hs
View File

@ -18,6 +18,7 @@ import Prelude
import Control.Monad (void)
import Data.Aeson
import Data.IORef (newIORef)
import qualified Data.Scientific as Sci
import IHaskell.Display
import IHaskell.Eval.Widgets
@ -49,18 +50,8 @@ mkRadioButtons = do
instance IHaskellWidget RadioButtons where
getCommUUID = uuid
comm widget val _ =
case nestedObjectLookup val ["sync_data", "selected_label"] of
Just (String label) -> do
opts <- getField widget Options
case opts of
OptionLabels _ -> do
void $ setField' widget SelectedLabel label
void $ setField' widget SelectedValue label
OptionDict ps ->
case lookup label ps of
Nothing -> pure ()
Just value -> do
void $ setField' widget SelectedLabel label
void $ setField' widget SelectedValue value
case nestedObjectLookup val ["state", "index"] of
Just (Number index) -> do
void $ setField' widget Index (Sci.coefficient index)
triggerSelection widget
_ -> pure ()

17
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/Select.hs
View File

@ -18,6 +18,7 @@ import Prelude
import Control.Monad (void)
import Data.Aeson
import Data.IORef (newIORef)
import qualified Data.Scientific as Sci
import IHaskell.Display
import IHaskell.Eval.Widgets
@ -49,18 +50,8 @@ mkSelect = do
instance IHaskellWidget Select where
getCommUUID = uuid
comm widget val _ =
case nestedObjectLookup val ["sync_data", "selected_label"] of
Just (String label) -> do
opts <- getField widget Options
case opts of
OptionLabels _ -> do
void $ setField' widget SelectedLabel label
void $ setField' widget SelectedValue label
OptionDict ps ->
case lookup label ps of
Nothing -> pure ()
Just value -> do
void $ setField' widget SelectedLabel label
void $ setField' widget SelectedValue value
case nestedObjectLookup val ["state", "index"] of
Just (Number index) -> do
void $ setField' widget Index (Sci.coefficient index)
triggerSelection widget
_ -> pure ()

19
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/SelectMultiple.hs
View File

@ -18,6 +18,7 @@ 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 IHaskell.Display
@ -50,19 +51,9 @@ mkSelectMultiple = do
instance IHaskellWidget SelectMultiple where
getCommUUID = uuid
comm widget val _ =
case nestedObjectLookup val ["sync_data", "selected_labels"] of
Just (Array labels) -> do
let labelList = map (\(String x) -> x) $ V.toList labels
opts <- getField widget Options
case opts of
OptionLabels _ -> do
void $ setField' widget SelectedLabels labelList
void $ setField' widget SelectedValues labelList
OptionDict ps ->
case mapM (`lookup` ps) labelList of
Nothing -> pure ()
Just valueList -> do
void $ setField' widget SelectedLabels labelList
void $ setField' widget SelectedValues valueList
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 ()

17
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/ToggleButtons.hs
View File

@ -18,6 +18,7 @@ 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
@ -55,18 +56,8 @@ mkToggleButtons = do
instance IHaskellWidget ToggleButtons where
getCommUUID = uuid
comm widget val _ =
case nestedObjectLookup val ["sync_data", "selected_label"] of
Just (String label) -> do
opts <- getField widget Options
case opts of
OptionLabels _ -> void $ do
void $ setField' widget SelectedLabel label
void $ setField' widget SelectedValue label
OptionDict ps ->
case lookup label ps of
Nothing -> pure ()
Just value -> do
void $ setField' widget SelectedLabel label
void $ setField' widget SelectedValue value
case nestedObjectLookup val ["state", "index"] of
Just (Number index) -> do
void $ setField' widget Index (Sci.coefficient index)
triggerSelection widget
_ -> pure ()

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

@ -68,13 +68,11 @@ singletons
| ImageFormat
| BoolValue
| Options
| SelectedLabel
| SelectedValue
| Index
| SelectionHandler
| Tooltips
| Icons
| SelectedLabels
| SelectedValues
| Indices
| IntValue
| StepInt
| MaxInt

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

@ -136,10 +136,10 @@ type StringClass = DOMWidgetClass :++ ['S.StringValue, 'S.Disabled, 'S.Descripti
type BoolClass = DOMWidgetClass :++ ['S.BoolValue, 'S.Disabled, 'S.Description, 'S.ChangeHandler]
type SelectionClass = DOMWidgetClass :++ ['S.Options, 'S.SelectedValue, 'S.SelectedLabel, 'S.Disabled,
type SelectionClass = DOMWidgetClass :++ ['S.Options, 'S.Index, 'S.Disabled,
'S.Description, 'S.SelectionHandler]
type MultipleSelectionClass = DOMWidgetClass :++ ['S.Options, 'S.SelectedValues, 'S.SelectedLabels, 'S.Disabled,
type MultipleSelectionClass = DOMWidgetClass :++ ['S.Options, 'S.Indices, 'S.Disabled,
'S.Description, 'S.SelectionHandler]
type IntClass = DOMWidgetClass :++ ['S.IntValue, 'S.Disabled, 'S.Description, 'S.ChangeHandler]
@ -202,13 +202,11 @@ type family FieldType (f :: Field) :: * where
FieldType 'S.ImageFormat = ImageFormatValue
FieldType 'S.BoolValue = Bool
FieldType 'S.Options = SelectionOptions
FieldType 'S.SelectedLabel = Text
FieldType 'S.SelectedValue = Text
FieldType 'S.Index = Integer
FieldType 'S.SelectionHandler = IO ()
FieldType 'S.Tooltips = [Text]
FieldType 'S.Icons = [Text]
FieldType 'S.SelectedLabels = [Text]
FieldType 'S.SelectedValues = [Text]
FieldType 'S.Indices = [Integer]
FieldType 'S.IntValue = Integer
FieldType 'S.StepInt = Integer
FieldType 'S.MinInt = Integer
@ -490,11 +488,8 @@ instance ToPairs (Attr 'S.ImageFormat) where
instance ToPairs (Attr 'S.BoolValue) where
toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr 'S.SelectedLabel) where
toPairs x = ["selected_label" .= toJSON x]
instance ToPairs (Attr 'S.SelectedValue) where
toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr 'S.Index) where
toPairs x = ["index" .= toJSON x]
instance ToPairs (Attr 'S.Options) where
toPairs x =
@ -514,11 +509,8 @@ instance ToPairs (Attr 'S.Tooltips) where
instance ToPairs (Attr 'S.Icons) where
toPairs x = ["icons" .= toJSON x]
instance ToPairs (Attr 'S.SelectedLabels) where
toPairs x = ["selected_labels" .= toJSON x]
instance ToPairs (Attr 'S.SelectedValues) where
toPairs x = ["values" .= toJSON x]
instance ToPairs (Attr 'S.Indices) where
toPairs x = ["index" .= toJSON x]
instance ToPairs (Attr 'S.IntValue) where
toPairs x = ["value" .= toJSON x]
@ -710,8 +702,7 @@ defaultSelectionWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec
defaultSelectionWidget viewName modelName = defaultDOMWidget viewName modelName <+> selectionAttrs
where
selectionAttrs = (Options =:: OptionLabels [])
:& (SelectedValue =:: "")
:& (SelectedLabel =:: "")
:& (Index =:: 0)
:& (Disabled =:: False)
:& (Description =:: "")
:& (SelectionHandler =:: return ())
@ -722,8 +713,7 @@ defaultMultipleSelectionWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelNam
defaultMultipleSelectionWidget viewName modelName = defaultDOMWidget viewName modelName <+> mulSelAttrs
where
mulSelAttrs = (Options =:: OptionLabels [])
:& (SelectedValues =:: [])
:& (SelectedLabels =:: [])
:& (Indices =:: [])
:& (Disabled =:: False)
:& (Description =:: "")
:& (SelectionHandler =:: return ())

2
src/IHaskell/Types.hs
View File

@ -43,7 +43,7 @@ module IHaskell.Types (
import IHaskellPrelude
import qualified Data.HashMap.Strict as HashMap
import Data.Aeson (ToJSON (..), Value, (.=), object, Object, Value(String))
import Data.Aeson (ToJSON (..), Value, (.=), object, Value(String))
import Data.Function (on)
import Data.Text (pack)
import Data.Serialize