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 bool widgets

Browse Source
This commit is contained in:
Sumit Sahrawat 2015-07-04 11:13:16 +05:30
parent 26903b1e11
commit 22abf97732
6 changed files with 161 additions and 7 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

@ -56,6 +56,8 @@ library
-- Modules included in this library but not exported.
other-modules: IHaskell.Display.Widgets.Button
IHaskell.Display.Widgets.Image
IHaskell.Display.Widgets.Bool.CheckBox
IHaskell.Display.Widgets.Bool.ToggleButton
-- IHaskell.Display.Widgets.Dropdown
IHaskell.Display.Widgets.String.HTML
IHaskell.Display.Widgets.String.Latex

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

@ -2,6 +2,9 @@ module IHaskell.Display.Widgets (module X) where
import IHaskell.Display.Widgets.Button as X
import IHaskell.Display.Widgets.Bool.CheckBox as X
import IHaskell.Display.Widgets.Bool.ToggleButton as X
-- import IHaskell.Display.Widgets.Dropdown as X
import IHaskell.Display.Widgets.Image as X

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

@ -0,0 +1,64 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Bool.CheckBox (
-- * The CheckBox Widget
CheckBoxWidget,
-- * Constructor
mkCheckBoxWidget,
) 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 hiding (Widget)
import IHaskell.Eval.Widgets
import IHaskell.IPython.Message.UUID as U
import IHaskell.Display.Widgets.Types
import IHaskell.Display.Widgets.Common
-- | A 'CheckBoxWidget' represents a Checkbox widget from IPython.html.widgets.
type CheckBoxWidget = Widget CheckBoxType
-- | Create a new output widget
mkCheckBoxWidget :: IO CheckBoxWidget
mkCheckBoxWidget = do
-- Default properties, with a random uuid
uuid <- U.random
let widgetState = WidgetState $ defaultBoolWidget "CheckboxView"
stateIO <- newIORef widgetState
let widget = Widget uuid stateIO
initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Checkbox"]
-- Open a comm for this widget, and store it in the kernel state
widgetSendOpen widget initData $ toJSON widgetState
-- Return the image widget
return widget
instance IHaskellDisplay CheckBoxWidget where
display b = do
widgetSendView b
return $ Display []
instance IHaskellWidget CheckBoxWidget where
getCommUUID = uuid
comm widget (Object dict1) _ = do
let key1 = "sync_data" :: Text
key2 = "value" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (Bool value) = HM.lookup key2 dict2
setField' widget SBoolValue value

69
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Bool/ToggleButton.hs Normal file
View File

@ -0,0 +1,69 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Bool.ToggleButton (
-- * The ToggleButton Widget
ToggleButton,
-- * Constructor
mkToggleButton,
) 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 hiding (Widget)
import IHaskell.Eval.Widgets
import IHaskell.IPython.Message.UUID as U
import IHaskell.Display.Widgets.Types
import IHaskell.Display.Widgets.Common
-- | A 'ToggleButton' represents a ToggleButton widget from IPython.html.widgets.
type ToggleButton = Widget ToggleButtonType
-- | Create a new output widget
mkToggleButton :: IO ToggleButton
mkToggleButton = do
-- Default properties, with a random uuid
uuid <- U.random
let boolState = defaultBoolWidget "ToggleButtonView"
toggleState = (STooltip =:: "")
:& (SIcon =:: "")
:& (SButtonStyle =:: DefaultButton)
:& RNil
widgetState = WidgetState (boolState <+> toggleState)
stateIO <- newIORef widgetState
let widget = Widget uuid stateIO
initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.ToggleButton"]
-- Open a comm for this widget, and store it in the kernel state
widgetSendOpen widget initData $ toJSON widgetState
-- Return the image widget
return widget
instance IHaskellDisplay ToggleButton where
display b = do
widgetSendView b
return $ Display []
instance IHaskellWidget ToggleButton where
getCommUUID = uuid
comm widget (Object dict1) _ = do
let key1 = "sync_data" :: Text
key2 = "value" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (Bool value) = HM.lookup key2 dict2
setField' widget SBoolValue value

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

@ -71,6 +71,7 @@ singletons [d|
| ButtonStyle
| B64Value
| ImageFormat
| BoolValue
deriving (Eq, Ord, Show)
|]

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

@ -27,8 +27,9 @@ import Data.Proxy
import Data.Vinyl (Rec (..), (<+>), recordToList, reifyConstraint, rmap, Dict (..))
import Data.Vinyl.Functor (Compose (..), Const (..))
import Data.Vinyl.Lens (rget, rput, type (∈))
import qualified Data.Vinyl.TypeLevel as TL
import Data.Vinyl.TypeLevel (RecAll (..))
import Data.Singletons.Prelude ((:++))
import Data.Singletons.TH
import Numeric.Natural
@ -41,12 +42,13 @@ import IHaskell.Display.Widgets.Common
-- Classes from IPython's widget hierarchy
type WidgetClass = '[ModelModule, ModelName, ViewModule, ViewName, MsgThrottle, Version, OnDisplayed]
type DOMWidgetClass = WidgetClass TL.++
type DOMWidgetClass = WidgetClass :++
'[ Visible, CSS, DOMClasses, Width, Height, Padding, Margin, Color
, BackgroundColor, BorderColor, BorderWidth, BorderRadius, BorderStyle, FontStyle
, FontWeight, FontSize, FontFamily
]
type StringClass = DOMWidgetClass TL.++ '[StringValue, Disabled, Description, Placeholder]
type StringClass = DOMWidgetClass :++ '[StringValue, Disabled, Description, Placeholder]
type BoolClass = DOMWidgetClass :++ '[BoolValue, Disabled, Description]
-- Types associated with Fields
type family FieldType (f :: Field) :: * where
@ -85,6 +87,7 @@ type family FieldType (f :: Field) :: * where
FieldType ButtonStyle = ButtonStyleValue
FieldType B64Value = Base64
FieldType ImageFormat = ImageFormatValue
FieldType BoolValue = Bool
data WidgetType = ButtonType
| ImageType
@ -93,15 +96,19 @@ data WidgetType = ButtonType
| LatexType
| TextType
| TextAreaType
| CheckBoxType
| ToggleButtonType
type family WidgetFields (w :: WidgetType) :: [Field] where
WidgetFields ButtonType = DOMWidgetClass TL.++ '[Description, Tooltip, Disabled, Icon, ButtonStyle, ClickHandler]
WidgetFields ImageType = DOMWidgetClass TL.++ '[ImageFormat, B64Value]
WidgetFields ButtonType = DOMWidgetClass :++ '[Description, Tooltip, Disabled, Icon, ButtonStyle, ClickHandler]
WidgetFields ImageType = DOMWidgetClass :++ '[ImageFormat, B64Value]
WidgetFields OutputType = DOMWidgetClass
WidgetFields HTMLType = StringClass
WidgetFields LatexType = StringClass
WidgetFields TextType = StringClass TL.++ '[SubmitHandler]
WidgetFields TextType = StringClass :++ '[SubmitHandler]
WidgetFields TextAreaType = StringClass
WidgetFields CheckBoxType = BoolClass
WidgetFields ToggleButtonType = BoolClass :++ '[Tooltip, Icon, ButtonStyle]
newtype Attr f = Attr { _unAttr :: FieldType f }
@ -144,6 +151,7 @@ instance ToPairs (Attr Icon) where toPairs (Attr x) = ["icon" .= toJSON x]
instance ToPairs (Attr ButtonStyle) where toPairs (Attr x) = ["button_style" .= toJSON x]
instance ToPairs (Attr B64Value) where toPairs (Attr x) = ["_b64value" .= toJSON x]
instance ToPairs (Attr ImageFormat) where toPairs (Attr x) = ["format" .= toJSON x]
instance ToPairs (Attr BoolValue) where toPairs (Attr x) = ["value" .= toJSON x]
(=::) :: sing f -> FieldType f -> Attr f
_ =:: x = Attr x
@ -187,10 +195,17 @@ defaultStringWidget viewName = defaultDOMWidget viewName <+> strAttrs
:& (SPlaceholder =:: "")
:& RNil
defaultBoolWidget :: FieldType ViewName -> Rec Attr BoolClass
defaultBoolWidget viewName = defaultDOMWidget viewName <+> boolAttrs
where boolAttrs = (SBoolValue =:: False)
:& (SDisabled =:: False)
:& (SDescription =:: "")
:& 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.
instance TL.RecAll Attr (WidgetFields w) ToPairs => ToJSON (WidgetState w) where
instance RecAll Attr (WidgetFields w) ToPairs => ToJSON (WidgetState w) where
toJSON record =
object
. concat