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

Add first box widget

Browse Source 
- Also added on_display handler (still unused though).
- Add uuidToString for UUIDs.
-
This commit is contained in:
Sumit Sahrawat 2015-07-14 02:07:03 +05:30
parent 38049d975a
commit bcbeddc131
6 changed files with 158 additions and 27 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

@ -55,6 +55,7 @@ library
-- Modules included in this library but not exported.
other-modules: IHaskell.Display.Widgets.Button
IHaskell.Display.Widgets.Box.Box
IHaskell.Display.Widgets.Bool.CheckBox
IHaskell.Display.Widgets.Bool.ToggleButton
IHaskell.Display.Widgets.Int.IntText

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

@ -2,6 +2,8 @@ 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.Bool.CheckBox as X
import IHaskell.Display.Widgets.Bool.ToggleButton as X
@ -35,4 +37,10 @@ import IHaskell.Display.Widgets.String.TextArea as X
import IHaskell.Display.Widgets.Common as X
import IHaskell.Display.Widgets.Types as X (setField, getField, properties)
import IHaskell.Display.Widgets.Types as X (triggerChange, triggerClick, triggerSelection, triggerSubmit)
import IHaskell.Display.Widgets.Types as X ( triggerDisplay
, triggerChange
, triggerClick
, triggerSelection
, triggerSubmit
, ChildWidget (..)
)

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

@ -0,0 +1,65 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Box.Box (
-- * The Box widget
Box,
-- * Constructor
mkBox,
) 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 'Box' represents a Box widget from IPython.html.widgets.
type Box = IPythonWidget BoxType
-- | Create a new box
mkBox :: IO Box
mkBox = do
-- Default properties, with a random uuid
uuid <- U.random
let widgetState = WidgetState $ defaultBoxWidget "BoxView"
stateIO <- newIORef widgetState
let box = IPythonWidget uuid stateIO
initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Box"]
-- 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 Box where
display b = do
widgetSendView b
return $ Display []
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

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

@ -16,13 +16,11 @@ import Data.Singletons.TH
-- Widget properties
singletons [d|
data Field = ModelModule
| ModelName
| ViewModule
data Field = ViewModule
| ViewName
| MsgThrottle
| Version
| OnDisplayed
| DisplayHandler
| Visible
| CSS
| DOMClasses
@ -80,6 +78,10 @@ singletons [d|
| SliderColor
| BarStyle
| ChangeHandler
| Children
| OverflowX
| OverflowY
| BoxStyle
deriving (Eq, Ord, Show)
|]
@ -206,3 +208,33 @@ data OrientationValue = HorizontalOrientation
instance ToJSON OrientationValue where
toJSON HorizontalOrientation = "horizontal"
toJSON VerticalOrientation = "vertical"
data OverflowValue = VisibleOverflow
| HiddenOverflow
| ScrollOverflow
| AutoOverflow
| InitialOverflow
| InheritOverflow
| DefaultOverflow
instance ToJSON OverflowValue where
toJSON VisibleOverflow = "visible"
toJSON HiddenOverflow = "hidden"
toJSON ScrollOverflow = "scroll"
toJSON AutoOverflow = "auto"
toJSON InitialOverflow = "initial"
toJSON InheritOverflow = "inherit"
toJSON DefaultOverflow = ""
data BoxStyleValue = SuccessBox
| InfoBox
| WarningBox
| DangerBox
| DefaultBox
instance ToJSON BoxStyleValue where
toJSON SuccessBox = "success"
toJSON InfoBox = "info"
toJSON WarningBox = "warning"
toJSON DangerBox = "danger"
toJSON DefaultBox = ""

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

@ -11,6 +11,7 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
module IHaskell.Display.Widgets.Types where
-- | This module houses all the type-trickery needed to make widgets happen.
@ -53,14 +54,14 @@ import Control.Applicative ((<$>))
import qualified Control.Exception as Ex
import Data.Aeson
import Data.Aeson.Types (emptyObject, Pair)
import Data.Text (pack, Text)
import Data.Aeson.Types (Pair)
import Data.IORef (IORef, readIORef, modifyIORef)
import Data.Text (Text, pack)
import Data.Vinyl (Rec (..), (<+>), recordToList, reifyConstraint, rmap, Dict (..))
import Data.Vinyl.Functor (Compose (..), Const (..))
import Data.Vinyl.Lens (rget, rput, type (∈))
import Data.Vinyl.TypeLevel (RecAll (..))
import Data.Vinyl.TypeLevel (RecAll)
import Data.Singletons.Prelude ((:++))
import Data.Singletons.TH
@ -72,7 +73,7 @@ import IHaskell.IPython.Message.UUID
import IHaskell.Display.Widgets.Common
-- Classes from IPython's widget hierarchy. Defined as such to reduce code duplication.
type WidgetClass = '[ModelModule, ModelName, ViewModule, ViewName, MsgThrottle, Version, OnDisplayed]
type WidgetClass = '[ViewModule, ViewName, MsgThrottle, Version, DisplayHandler]
type DOMWidgetClass = WidgetClass :++
'[ Visible, CSS, DOMClasses, Width, Height, Padding, Margin, Color
, BackgroundColor, BorderColor, BorderWidth, BorderRadius, BorderStyle, FontStyle
@ -92,16 +93,15 @@ type FloatClass = DOMWidgetClass :++ '[FloatValue, Disabled, Description, Change
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]
-- Types associated with Fields.
type family FieldType (f :: Field) :: * where
FieldType ModelModule = Text
FieldType ModelName = Text
FieldType ViewModule = Text
FieldType ViewName = Text
FieldType MsgThrottle = StrInt
FieldType Version = StrInt
FieldType OnDisplayed = IO ()
FieldType MsgThrottle = Integer
FieldType Version = Integer
FieldType DisplayHandler = IO ()
FieldType Visible = Bool
FieldType CSS = [(Text, Text, Text)]
FieldType DOMClasses = [Text]
@ -159,6 +159,16 @@ type family FieldType (f :: Field) :: * where
FieldType UpperFloat = Double
FieldType FloatPairValue = (Double, Double)
FieldType ChangeHandler = IO ()
FieldType Children = [ChildWidget]
FieldType OverflowX = OverflowValue
FieldType OverflowY = OverflowValue
FieldType BoxStyle = BoxStyleValue
-- | 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)
instance ToJSON ChildWidget where
toJSON (ChildWidget x) = toJSON . pack $ "IPY_MODEL_" ++ uuidToString (uuid x)
-- Will use a custom class rather than a newtype wrapper with an orphan instance. The main issue is
-- the need of a Bounded instance for Float / Double.
@ -204,6 +214,8 @@ data WidgetType = ButtonType
| FloatSliderType
| FloatProgressType
| FloatRangeSliderType
| BoxType
| FlexBoxType
-- Fields associated with a widget
type family WidgetFields (w :: WidgetType) :: [Field] where
@ -231,6 +243,8 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
WidgetFields FloatSliderType = BoundedFloatClass :++ '[Orientation, ShowRange, ReadOut, SliderColor]
WidgetFields FloatProgressType = BoundedFloatClass :++ '[BarStyle]
WidgetFields FloatRangeSliderType = BoundedFloatRangeClass :++ '[Orientation, ShowRange, ReadOut, SliderColor]
WidgetFields BoxType = BoxClass
WidgetFields FlexBoxType = BoxClass
-- 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
@ -256,13 +270,11 @@ class ToPairs a where
toPairs :: a -> [Pair]
-- Attributes that aren't synced with the frontend give [] on toPairs
instance ToPairs (Attr ModelModule) where toPairs x = ["_model_module" .= toJSON x]
instance ToPairs (Attr ModelName) where toPairs x = ["_model_name" .= toJSON x]
instance ToPairs (Attr ViewModule) where toPairs x = ["_view_module" .= toJSON x]
instance ToPairs (Attr ViewName) where toPairs x = ["_view_name" .= toJSON x]
instance ToPairs (Attr MsgThrottle) where toPairs x = ["msg_throttle" .= toJSON x]
instance ToPairs (Attr Version) where toPairs x = ["version" .= toJSON x]
instance ToPairs (Attr OnDisplayed) where toPairs _ = [] -- Not sent to the frontend
instance ToPairs (Attr DisplayHandler) where toPairs _ = [] -- Not sent to the frontend
instance ToPairs (Attr Visible) where toPairs x = ["visible" .= toJSON x]
instance ToPairs (Attr CSS) where toPairs x = ["_css" .= toJSON x]
instance ToPairs (Attr DOMClasses) where toPairs x = ["_dom_classes" .= toJSON x]
@ -325,6 +337,10 @@ instance ToPairs (Attr ReadOut) where toPairs x = ["readout" .= toJSON x]
instance ToPairs (Attr SliderColor) where toPairs x = ["slider_color" .= toJSON x]
instance ToPairs (Attr BarStyle) where toPairs x = ["bar_style" .= toJSON x]
instance ToPairs (Attr ChangeHandler) where toPairs _ = [] -- Not sent to the frontend
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]
-- | Store the value for a field, as an object parametrized by the Field. No verification is done
-- for these values.
@ -357,13 +373,11 @@ reflect = fromSing
-- | A record representing an object of the Widget class from IPython
defaultWidget :: FieldType ViewName -> Rec Attr WidgetClass
defaultWidget viewName = (SModelModule =:: "")
:& (SModelName =:: "WidgetModel")
:& (SViewModule =:: "")
defaultWidget viewName = (SViewModule =:: "")
:& (SViewName =:: viewName)
:& (SMsgThrottle =:+ 3)
:& (SVersion =:: 0)
:& (SOnDisplayed =:: return ())
:& (SDisplayHandler =:: return ())
:& RNil
-- | A record representing an object of the DOMWidget class from IPython
@ -490,9 +504,17 @@ defaultFloatRangeWidget viewName = defaultFloatWidget viewName <+> rangeAttrs
defaultBoundedFloatRangeWidget :: FieldType ViewName -> Rec Attr BoundedFloatRangeClass
defaultBoundedFloatRangeWidget viewName = defaultFloatRangeWidget viewName <+> boundedFloatRangeAttrs
where boundedFloatRangeAttrs = (SStepFloat =:+ 1)
:& (SMinFloat =:: 0)
:& (SMaxFloat =:: 100)
:& RNil
:& (SMinFloat =:: 0)
:& (SMaxFloat =:: 100)
:& RNil
defaultBoxWidget :: FieldType ViewName -> Rec Attr BoxClass
defaultBoxWidget viewName = defaultDOMWidget viewName <+> boxAttrs
where boxAttrs = (SChildren =:: [])
:& (SOverflowX =:: DefaultOverflow)
:& (SOverflowY =:: DefaultOverflow)
:& (SBoxStyle =:: DefaultBox)
:& RNil
newtype WidgetState w = WidgetState { _getState :: Rec Attr (WidgetFields w) }
@ -556,3 +578,6 @@ triggerSelection w = join $ getField w SSelectionHandler
triggerSubmit :: (SubmitHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerSubmit w = join $ getField w SSubmitHandler
triggerDisplay :: (DisplayHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerDisplay w = join $ getField w SDisplayHandler

6
ipython-kernel/src/IHaskell/IPython/Message/UUID.hs
View File

@ -1,7 +1,7 @@
-- | Description : UUID generator and data structure
--
-- Generate, parse, and pretty print UUIDs for use with IPython.
module IHaskell.IPython.Message.UUID (UUID, random, randoms) where
module IHaskell.IPython.Message.UUID (UUID, random, randoms, uuidToString) where
import Control.Monad (mzero, replicateM)
import Control.Applicative ((<$>))
@ -16,7 +16,7 @@ data UUID =
-- present in the correct locations. For the purposes of new UUIDs, it does not matter,
-- but IPython expects UUIDs passed to kernels to be returned unchanged, so we cannot
-- actually parse them.
UUID String
UUID { uuidToString :: String }
deriving (Show, Read, Eq, Ord)
-- | Generate a list of random UUIDs.
@ -28,7 +28,7 @@ randoms n = replicateM n random
random :: IO UUID
random = UUID <$> show <$> nextRandom
-- Allows reading and writing UUIDs as Strings in JSON.
-- Allows reading and writing UUIDs as Strings in JSON.
instance FromJSON UUID where
parseJSON val@(String _) = UUID <$> parseJSON val