Skip to content

G
gargantext-ihaskell
Commit 4e6f20e2 authored by Sumit Sahrawat's avatar Sumit Sahrawat
Browse files
Options

Ultimate type-fu ~ A lot of vinyl 

- Widgets work, although it requires some tweaking to their properties.
- Dropping dropdown for now. Will deal with selection widgets later.
- Default properties need to be improved.
parent d798bc69
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 480 additions and 873 deletions
ihaskell-display/ihaskell-widgets/ihaskell-widgets.cabal
View file @ 4e6f20e2
...@@ -56,7 +56,7 @@ library ...@@ -56,7 +56,7 @@ library
-- Modules included in this library but not exported. -- Modules included in this library but not exported.
other-modules: IHaskell.Display.Widgets.Button other-modules: IHaskell.Display.Widgets.Button
IHaskell.Display.Widgets.Image IHaskell.Display.Widgets.Image
IHaskell.Display.Widgets.Dropdown -- IHaskell.Display.Widgets.Dropdown
IHaskell.Display.Widgets.String.HTML IHaskell.Display.Widgets.String.HTML
IHaskell.Display.Widgets.String.Latex IHaskell.Display.Widgets.String.Latex
IHaskell.Display.Widgets.String.Text IHaskell.Display.Widgets.String.Text
...@@ -64,6 +64,7 @@ library ...@@ -64,6 +64,7 @@ library
IHaskell.Display.Widgets.Output IHaskell.Display.Widgets.Output
IHaskell.Display.Widgets.Types IHaskell.Display.Widgets.Types
IHaskell.Display.Widgets.Common
-- LANGUAGE extensions used by modules in this package. -- LANGUAGE extensions used by modules in this package.
-- other-extensions: -- other-extensions:
...@@ -77,6 +78,7 @@ library ...@@ -77,6 +78,7 @@ library
, unordered-containers >= 0.2.5.1 , unordered-containers >= 0.2.5.1
-- TODO: Need to check versions -- TODO: Need to check versions
, vinyl -any
, singletons -any , singletons -any
-- Waiting for the next release -- Waiting for the next release
......
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets.hs
View file @ 4e6f20e2
...@@ -2,7 +2,7 @@ module IHaskell.Display.Widgets (module X) where ...@@ -2,7 +2,7 @@ module IHaskell.Display.Widgets (module X) where
import IHaskell.Display.Widgets.Button as X import IHaskell.Display.Widgets.Button as X
import IHaskell.Display.Widgets.Dropdown as X -- import IHaskell.Display.Widgets.Dropdown as X
import IHaskell.Display.Widgets.Image as X import IHaskell.Display.Widgets.Image as X
...@@ -13,4 +13,5 @@ import IHaskell.Display.Widgets.String.TextArea as X ...@@ -13,4 +13,5 @@ import IHaskell.Display.Widgets.String.TextArea as X
import IHaskell.Display.Widgets.Output as X import IHaskell.Display.Widgets.Output as X
import IHaskell.Display.Widgets.Common as X (ButtonStyle(..), ImageFormat(..)) import IHaskell.Display.Widgets.Common as X
import IHaskell.Display.Widgets.Types as X (setField, setField', getField)
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Button.hs
View file @ 4e6f20e2
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Button ( module IHaskell.Display.Widgets.Button (
-- * The Button Widget -- * The Button Widget
...@@ -15,21 +16,18 @@ module IHaskell.Display.Widgets.Button ( ...@@ -15,21 +16,18 @@ module IHaskell.Display.Widgets.Button (
import Prelude import Prelude
import Control.Monad (when, join) import Control.Monad (when, join)
import Data.Aeson (ToJSON, Value(..), object, toJSON, (.=)) import Data.Aeson
import Data.Aeson.Types (Pair) import Data.HashMap.Strict as HM
import Data.Map as M import Data.IORef (newIORef)
import Data.HashMap.Strict as HashMap
import Data.IORef
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import Data.Vinyl (Rec (..), (<+>))
import System.IO.Unsafe (unsafePerformIO)
import IHaskell.Display hiding (Widget) import IHaskell.Display hiding (Widget)
import IHaskell.Eval.Widgets import IHaskell.Eval.Widgets
import qualified IHaskell.IPython.Message.UUID as U import IHaskell.IPython.Message.UUID as U
import IHaskell.Types (WidgetMethod(..))
import IHaskell.Display.Widgets.Types import IHaskell.Display.Widgets.Types
import IHaskell.Display.Widgets.Common
-- | A 'Button' represents a Button from IPython.html.widgets. -- | A 'Button' represents a Button from IPython.html.widgets.
type Button = Widget ButtonType type Button = Widget ButtonType
...@@ -40,23 +38,27 @@ mkButton = do ...@@ -40,23 +38,27 @@ mkButton = do
-- Default properties, with a random uuid -- Default properties, with a random uuid
uuid <- U.random uuid <- U.random
let dom = domWidgetWith "ButtonView" let dom = defaultDOMWidget "ButtonView"
but = [ SDescription ~= "" but = (SDescription =:: "")
, STooltip ~= "" :& (STooltip =:: "")
, SDisabled ~= False :& (SDisabled =:: False)
, SIcon ~= "" :& (SIcon =:: "")
, SButtonStyle ~= DefaultButton :& (SButtonStyle =:: DefaultButton)
, SClickHandler ~= return () :& (SClickHandler =:: return ())
] :& RNil
attributes = M.fromList $ dom ++ but buttonState = WidgetState (dom <+> but)
attrIO <- newIORef attributes stateIO <- newIORef buttonState
let button = Widget uuid attrIO :: Widget ButtonType let button = Widget uuid stateIO
initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Button"]
let initData = object
[ "model_name" .= str "WidgetModel"
, "widget_class" .= str "IPython.Button"
]
-- Open a comm for this widget, and store it in the kernel state -- Open a comm for this widget, and store it in the kernel state
widgetSendOpen button initData $ toJSON button widgetSendOpen button initData $ toJSON buttonState
-- Return the button widget -- Return the button widget
return button return button
...@@ -65,20 +67,6 @@ mkButton = do ...@@ -65,20 +67,6 @@ mkButton = do
triggerClick :: Button -> IO () triggerClick :: Button -> IO ()
triggerClick button = join $ getField button SClickHandler triggerClick button = join $ getField button SClickHandler
-- instance ToJSON Button where
-- toJSON b = object
-- [ "_view_name" .= str "ButtonView"
-- , "visible" .= True
-- , "_css" .= object []
-- , "msg_throttle" .= (3 :: Int)
-- , "disabled" .= get disabled b
-- , "description" .= get description b
-- , "tooltip" .= get tooltip b
-- , "button_style" .= get buttonStyle b
-- ]
-- where
-- get x y = unsafePerformIO . readIORef . x $ y
instance IHaskellDisplay Button where instance IHaskellDisplay Button where
display b = do display b = do
widgetSendView b widgetSendView b
...@@ -89,6 +77,6 @@ instance IHaskellWidget Button where ...@@ -89,6 +77,6 @@ instance IHaskellWidget Button where
comm widget (Object dict1) _ = do comm widget (Object dict1) _ = do
let key1 = "content" :: Text let key1 = "content" :: Text
key2 = "event" :: Text key2 = "event" :: Text
Just (Object dict2) = HashMap.lookup key1 dict1 Just (Object dict2) = HM.lookup key1 dict1
Just (String event) = HashMap.lookup key2 dict2 Just (String event) = HM.lookup key2 dict2
when (event == "click") $ triggerClick widget when (event == "click") $ triggerClick widget
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Common.hs
View file @ 4e6f20e2
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Common where
import Control.Monad (when)
import Data.Aeson
import Data.Aeson.Types (emptyObject, Pair)
import Data.Text (pack, Text)
import Data.IORef (IORef, readIORef, modifyIORef)
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.Singletons.TH
import IHaskell.Eval.Widgets (widgetSendUpdate)
import IHaskell.Display (Base64, IHaskellWidget (..))
import IHaskell.IPython.Message.UUID
-- Widget properties
singletons [d|
data Field = ModelModule
| ModelName
| ViewModule
| ViewName
| MsgThrottle
| Version
| OnDisplayed
| Visible
| CSS
| DOMClasses
| Width
| Height
| Padding
| Margin
| Color
| BackgroundColor
| BorderColor
| BorderWidth
| BorderRadius
| BorderStyle
| FontStyle
| FontWeight
| FontSize
| FontFamily
| Description
| ClickHandler
| SubmitHandler
| Disabled
| StringValue
| Placeholder
| Tooltip
| Icon
| ButtonStyle
| B64Value
| ImageFormat
deriving (Eq, Ord, Show)
|]
data BorderStyleValue = NoBorder
| HiddenBorder
| DottedBorder
| DashedBorder
| SolidBorder
| DoubleBorder
| GrooveBorder
| RidgeBorder
| InsetBorder
| OutsetBorder
| InitialBorder
| InheritBorder
| DefaultBorder
instance ToJSON BorderStyleValue where
toJSON NoBorder = "none"
toJSON HiddenBorder = "hidden"
toJSON DottedBorder = "dotted"
toJSON DashedBorder = "dashed"
toJSON SolidBorder = "solid"
toJSON DoubleBorder = "double"
toJSON GrooveBorder = "groove"
toJSON RidgeBorder = "ridge"
toJSON InsetBorder = "inset"
toJSON OutsetBorder = "outset"
toJSON InitialBorder = "initial"
toJSON InheritBorder = "inherit"
toJSON DefaultBorder = ""
data FontStyleValue = NormalFont
| ItalicFont
| ObliqueFont
| InitialFont
| InheritFont
| DefaultFont
instance ToJSON FontStyleValue where
toJSON NormalFont = "normal"
toJSON ItalicFont = "italic"
toJSON ObliqueFont = "oblique"
toJSON InitialFont = "initial"
toJSON InheritFont = "inherit"
toJSON DefaultFont = ""
data FontWeightValue = NormalWeight
| BoldWeight
| BolderWeight
| LighterWeight
| InheritWeight
| InitialWeight
| DefaultWeight
instance ToJSON FontWeightValue where
toJSON NormalWeight = "normal"
toJSON BoldWeight = "bold"
toJSON BolderWeight = "bolder"
toJSON LighterWeight = "lighter"
toJSON InheritWeight = "inherit"
toJSON InitialWeight = "initial"
toJSON DefaultWeight = ""
data ButtonStyleValue = PrimaryButton
| SuccessButton
| InfoButton
| WarningButton
| DangerButton
| DefaultButton
instance ToJSON ButtonStyleValue where
toJSON PrimaryButton = "primary"
toJSON SuccessButton = "success"
toJSON InfoButton = "info"
toJSON WarningButton = "warning"
toJSON DangerButton = "danger"
toJSON DefaultButton = ""
-- | Image formats for ImageWidget
data ImageFormatValue = PNG
| SVG
| JPG
deriving Eq
instance Show ImageFormatValue where
show PNG = "png"
show SVG = "svg"
show JPG = "jpg"
module IHaskell.Display.Widgets.Common ( instance ToJSON ImageFormatValue where
-- * Convenience types toJSON = toJSON . pack . show
PosInt(..),
-- * Convenience functions (for internal use)
update,
modify,
str,
) where
import Data.Aeson hiding (Success)
import Data.Aeson.Types (Pair)
import qualified Data.Text as T
import IHaskell.Display
import IHaskell.Eval.Widgets
import IHaskell.IPython.Message.UUID
-- | A wrapper around Int. 'toJSON' gives the no. for positive numbers, and empty string otherwise
newtype PosInt = PosInt { unwrap :: Int }
instance ToJSON PosInt where
toJSON (PosInt n)
| n > 0 = toJSON $ str $ show n
| otherwise = toJSON $ str $ ""
-- | Send an update msg for a widget, with custom json. Make it easy to update fragments of the
-- state, by accepting a Pair instead of a Value.
update :: IHaskellWidget a => a -> [Pair] -> IO ()
update widget = widgetSendUpdate widget . toJSON . object
-- | Modify attributes of a widget, stored inside it as IORefs
modify :: IHaskellWidget a => a -> (a -> IORef b) -> b -> IO ()
modify widget attr newval = writeIORef (attr widget) newval
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Image.hs
View file @ 4e6f20e2
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Image ( module IHaskell.Display.Widgets.Image (
-- * The Image Widget -- * The Image Widget
ImageWidget, ImageWidget,
-- * Create a new image widget -- * Constructor
mkImageWidget, mkImageWidget,
-- * Set image properties
setImageFormat,
setImageB64Value,
setImageWidth,
setImageHeight,
-- * Get image properties
getImageFormat,
getImageB64Value,
getImageWidth,
getImageHeight,
) where ) where
-- To keep `cabal repl` happy when running from the ihaskell repo -- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude import Prelude
import Control.Monad (when) import Control.Monad (when, join)
import Data.Aeson (ToJSON, Value(..), object, toJSON, (.=)) import Data.Aeson
import Data.Aeson.Types (Pair) import Data.HashMap.Strict as HM
import Data.HashMap.Strict as Map import Data.IORef (newIORef)
import Data.IORef
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import Data.Vinyl (Rec (..), (<+>))
import System.IO.Unsafe (unsafePerformIO)
import IHaskell.Display import IHaskell.Display hiding (Widget)
import IHaskell.Eval.Widgets import IHaskell.Eval.Widgets
import qualified IHaskell.IPython.Message.UUID as U import IHaskell.IPython.Message.UUID as U
import IHaskell.Types (WidgetMethod(..))
import IHaskell.Display.Widgets.Types
import IHaskell.Display.Widgets.Common import IHaskell.Display.Widgets.Common
-- | A 'Image' represents a Image from IPython.html.widgets. -- | An 'ImageWidget' represents a Image widget from IPython.html.widgets.
data ImageWidget = type ImageWidget = Widget ImageType
ImageWidget
{ uuid :: U.UUID
, format :: IORef ImageFormat
, height :: IORef PosInt
, width :: IORef PosInt
, b64value :: IORef Base64
}
-- | Create a new image widget -- | Create a new image widget
mkImageWidget :: IO ImageWidget mkImageWidget :: IO ImageWidget
mkImageWidget = do mkImageWidget = do
-- Default properties, with a random uuid -- Default properties, with a random uuid
commUUID <- U.random uuid <- U.random
fmt <- newIORef PNG
hgt <- newIORef (PosInt 0)
wdt <- newIORef (PosInt 0)
val <- newIORef ""
let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Image"] let dom = defaultDOMWidget "ImageView"
b = ImageWidget { uuid = commUUID, format = fmt, height = hgt, width = wdt, b64value = val } img = (SImageFormat =:: PNG)
:& (SB64Value =:: mempty)
:& RNil
widgetState = WidgetState (dom <+> img)
-- Open a comm for this widget, and store it in the kernel state stateIO <- newIORef widgetState
widgetSendOpen b initData (toJSON b)
-- Return the image widget
return b
-- | Set the image style
setImageFormat :: ImageWidget -> ImageFormat -> IO ()
setImageFormat b fmt = do
modify b format fmt
update b ["format" .= fmt]
-- | Set the image value (encoded in base64)
setImageB64Value :: ImageWidget -> Base64 -> IO ()
setImageB64Value b val = do
modify b b64value val
update b ["_b64value" .= val]
-- | Set the image width let widget = Widget uuid stateIO
setImageWidth :: ImageWidget -> Int -> IO ()
setImageWidth b wdt = do
let w = PosInt wdt
modify b width w
update b ["width" .= w]
-- | Set the image height let initData = object
setImageHeight :: ImageWidget -> Int -> IO () [ "model_name" .= str "WidgetModel"
setImageHeight b hgt = do , "widget_class" .= str "IPython.Image"
let h = PosInt hgt ]
modify b height h
update b ["height" .= h]
-- | Get the image format -- Open a comm for this widget, and store it in the kernel state
getImageFormat :: ImageWidget -> IO ImageFormat widgetSendOpen widget initData $ toJSON widgetState
getImageFormat = readIORef . format
-- | Get the image value (encoded in base64)
getImageB64Value :: ImageWidget -> IO Base64
getImageB64Value = readIORef . b64value
-- | Get the image width
getImageWidth :: ImageWidget -> IO Int
getImageWidth = fmap unwrap . readIORef . width
-- | Get the image height
getImageHeight :: ImageWidget -> IO Int
getImageHeight = fmap unwrap . readIORef . height
instance ToJSON ImageWidget where -- Return the image widget
toJSON b = object return widget
[ "_view_module" .= str ""
, "background_color" .= str ""
, "border_width" .= str ""
, "border_color" .= str ""
, "width" .= get width b
, "_dom_classes" .= object []
, "margin" .= str ""
, "font_style" .= str ""
, "font_weight" .= str ""
, "height" .= get height b
, "font_size" .= str ""
, "border_style" .= str ""
, "padding" .= str ""
, "border_radius" .= str ""
, "version" .= (0 :: Int)
, "font_family" .= str ""
, "color" .= str ""
, "_view_name" .= str "ImageView"
, "visible" .= True
, "_css" .= object []
, "msg_throttle" .= (3 :: Int)
, "format" .= get format b
, "_b64value" .= get b64value b
]
where
get x y = unsafePerformIO . readIORef . x $ y
instance IHaskellDisplay ImageWidget where instance IHaskellDisplay ImageWidget where
display b = do display b = do
......
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Output.hs
View file @ 4e6f20e2
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Output ( module IHaskell.Display.Widgets.Output (
-- * The Output Widget -- * The Output Widget
OutputWidget, OutputWidget,
-- * Constructor -- * Constructor
mkOutputWidget, mkOutputWidget,
-- * Get/Set/Modify width -- * Using the output widget
getOutputWidth,
setOutputWidth,
modifyOutputWidth,
modifyOutputWidth_,
-- * Output to widget
appendOutput, appendOutput,
clearOutput, clearOutput,
clearOutput_, clearOutput_,
...@@ -21,62 +18,40 @@ module IHaskell.Display.Widgets.Output ( ...@@ -21,62 +18,40 @@ module IHaskell.Display.Widgets.Output (
-- To keep `cabal repl` happy when running from the ihaskell repo -- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude import Prelude
import Control.Monad (when, void) import Control.Monad (when, join)
import Data.Aeson (ToJSON, Value(..), object, toJSON, (.=)) import Data.Aeson
import Data.Aeson.Types (Pair, Array) import Data.HashMap.Strict as HM
import qualified Data.HashMap.Strict as Map import Data.IORef (newIORef)
import Data.IORef
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import Data.Vinyl (Rec (..), (<+>))
import System.IO.Unsafe (unsafePerformIO)
import IHaskell.Display import IHaskell.Display hiding (Widget)
import IHaskell.Eval.Widgets import IHaskell.Eval.Widgets
import qualified IHaskell.IPython.Message.UUID as U import IHaskell.IPython.Message.UUID as U
import IHaskell.Types (WidgetMethod(..))
import IHaskell.Display.Widgets.Common import IHaskell.Display.Widgets.Types
data OutputWidget = OutputWidget { uuid :: U.UUID, width :: IORef PosInt } -- | An 'OutputWidget' represents a Output widget from IPython.html.widgets.
type OutputWidget = Widget OutputType
-- | Create a new output widget
mkOutputWidget :: IO OutputWidget mkOutputWidget :: IO OutputWidget
mkOutputWidget = do mkOutputWidget = do
-- Default properties, with a random uuid -- Default properties, with a random uuid
commUUID <- U.random uuid <- U.random
wdt <- newIORef $ PosInt 400
dis <- newIORef False
let b = OutputWidget { uuid = commUUID, width = wdt } let widgetState = WidgetState $ defaultDOMWidget "OutputView"
let initData = object ["model_name" .= str "WidgetModel"] stateIO <- newIORef widgetState
-- Open a comm for this widget, and store it in the kernel state let widget = Widget uuid stateIO
widgetSendOpen b initData (toJSON b) initData = object ["model_name" .= str "WidgetModel"]
-- Return the widget
return b
-- | Get the output widget width
getOutputWidth :: OutputWidget -> IO Int
getOutputWidth = fmap unwrap . readIORef . width
-- | Set the output widget width -- Open a comm for this widget, and store it in the kernel state
setOutputWidth :: OutputWidget -> Int -> IO () widgetSendOpen widget initData $ toJSON widgetState
setOutputWidth widget widthInt = do
let w = PosInt widthInt
modify widget width w
update widget ["width" .= w]
-- | Modify the output widget width (with IO)
modifyOutputWidth :: OutputWidget -> (Int -> IO Int) -> IO ()
modifyOutputWidth widget modifier = getOutputWidth widget >>= modifier >>= setOutputWidth widget
-- | Modify the output widget width (with pure modifier) -- Return the image widget
modifyOutputWidth_ :: OutputWidget -> (Int -> Int) -> IO () return widget
modifyOutputWidth_ widget modifier = do
w <- getOutputWidth widget
let newWidth = modifier w
setOutputWidth widget newWidth
-- | Append to the output widget -- | Append to the output widget
appendOutput :: IHaskellDisplay a => OutputWidget -> a -> IO () appendOutput :: IHaskellDisplay a => OutputWidget -> a -> IO ()
...@@ -98,33 +73,6 @@ replaceOutput widget d = do ...@@ -98,33 +73,6 @@ replaceOutput widget d = do
clearOutput_ widget clearOutput_ widget
appendOutput widget d appendOutput widget d
instance ToJSON OutputWidget where
toJSON b = object
[ "_view_module" .= str ""
, "background_color" .= str ""
, "border_width" .= str ""
, "border_color" .= str ""
, "width" .= get width b
, "_dom_classes" .= object []
, "margin" .= str ""
, "font_style" .= str ""
, "font_weight" .= str ""
, "height" .= str ""
, "font_size" .= str ""
, "border_style" .= str ""
, "padding" .= str ""
, "border_radius" .= str ""
, "version" .= (0 :: Int)
, "font_family" .= str ""
, "color" .= str ""
, "_view_name" .= str "OutputView"
, "visible" .= True
, "_css" .= object []
, "msg_throttle" .= (3 :: Int)
]
where
get x = unsafePerformIO . readIORef . x
instance IHaskellDisplay OutputWidget where instance IHaskellDisplay OutputWidget where
display b = do display b = do
widgetSendView b widgetSendView b
......
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/HTML.hs
View file @ 4e6f20e2
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.String.HTML ( module IHaskell.Display.Widgets.String.HTML (
-- * The HTML Widget -- * The HTML Widget
HTMLWidget, HTMLWidget,
-- * Constructor -- * Constructor
mkHTMLWidget, mkHTMLWidget,
-- * Set properties
setHTMLValue,
setHTMLDescription,
setHTMLPlaceholder,
-- * Get properties
getHTMLValue,
getHTMLDescription,
getHTMLPlaceholder,
) where ) where
-- To keep `cabal repl` happy when running from the ihaskell repo -- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude import Prelude
import Control.Monad (when) import Control.Monad (when, join)
import Data.Aeson (ToJSON, Value(..), object, toJSON, (.=)) import Data.Aeson
import Data.Aeson.Types (Pair) import Data.IORef (newIORef)
import Data.HashMap.Strict as Map
import Data.IORef
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import Data.Vinyl (Rec (..), (<+>))
import System.IO.Unsafe (unsafePerformIO)
import IHaskell.Display import IHaskell.Display hiding (Widget)
import IHaskell.Eval.Widgets import IHaskell.Eval.Widgets
import qualified IHaskell.IPython.Message.UUID as U import IHaskell.IPython.Message.UUID as U
import IHaskell.Display.Widgets.Common import IHaskell.Display.Widgets.Types
data HTMLWidget = -- | A 'HTMLWidget' represents a HTML widget from IPython.html.widgets.
HTMLWidget type HTMLWidget = Widget HTMLType
{ uuid :: U.UUID
, value :: IORef Text
, description :: IORef Text
, placeholder :: IORef Text
}
-- | Create a new HTML widget -- | Create a new HTML widget
mkHTMLWidget :: IO HTMLWidget mkHTMLWidget :: IO HTMLWidget
mkHTMLWidget = do mkHTMLWidget = do
-- Default properties, with a random uuid -- Default properties, with a random uuid
commUUID <- U.random uuid <- U.random
val <- newIORef "" let widgetState = WidgetState $ defaultStringWidget "HTMLView"
des <- newIORef ""
plc <- newIORef ""
let b = HTMLWidget { uuid = commUUID, value = val, description = des, placeholder = plc } stateIO <- newIORef widgetState
let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.HTML"] let widget = Widget uuid stateIO
initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.HTML"]
-- Open a comm for this widget, and store it in the kernel state -- Open a comm for this widget, and store it in the kernel state
widgetSendOpen b initData (toJSON b) widgetSendOpen widget initData $ toJSON widgetState
-- Return the string widget -- Return the widget
return b return widget
-- | Set the HTML string value.
setHTMLValue :: HTMLWidget -> Text -> IO ()
setHTMLValue b txt = do
modify b value txt
update b ["value" .= txt]
-- | Set the HTML description
setHTMLDescription :: HTMLWidget -> Text -> IO ()
setHTMLDescription b txt = do
modify b description txt
update b ["description" .= txt]
-- | Set the HTML placeholder, i.e. text displayed in empty widget
setHTMLPlaceholder :: HTMLWidget -> Text -> IO ()
setHTMLPlaceholder b txt = do
modify b placeholder txt
update b ["placeholder" .= txt]
-- | Get the HTML string value.
getHTMLValue :: HTMLWidget -> IO Text
getHTMLValue = readIORef . value
-- | Get the HTML description value.
getHTMLDescription :: HTMLWidget -> IO Text
getHTMLDescription = readIORef . description
-- | Get the HTML placeholder value.
getHTMLPlaceholder :: HTMLWidget -> IO Text
getHTMLPlaceholder = readIORef . placeholder
instance ToJSON HTMLWidget where
toJSON b = object
[ "_view_name" .= str "HTMLView"
, "visible" .= True
, "_css" .= object []
, "msg_throttle" .= (3 :: Int)
, "value" .= get value b
]
where
get x y = unsafePerformIO . readIORef . x $ y
instance IHaskellDisplay HTMLWidget where instance IHaskellDisplay HTMLWidget where
display b = do display b = do
......
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/Latex.hs
View file @ 4e6f20e2
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.String.Latex ( module IHaskell.Display.Widgets.String.Latex (
-- * The Latex Widget -- * The Latex Widget
LatexWidget, LatexWidget,
-- * Constructor -- * Constructor
mkLatexWidget, mkLatexWidget,
-- * Set properties
setLatexValue,
setLatexPlaceholder,
setLatexDescription,
setLatexWidth,
-- * Get properties
getLatexValue,
getLatexPlaceholder,
getLatexDescription,
getLatexWidth,
) where ) where
-- To keep `cabal repl` happy when running from the ihaskell repo -- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude import Prelude
import Control.Monad (when) import Control.Monad (when, join)
import Data.Aeson (ToJSON, Value(..), object, toJSON, (.=)) import Data.Aeson
import Data.Aeson.Types (Pair) import Data.IORef (newIORef)
import Data.HashMap.Strict as Map
import Data.IORef
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import Data.Vinyl (Rec (..), (<+>))
import System.IO.Unsafe (unsafePerformIO)
import IHaskell.Display import IHaskell.Display hiding (Widget)
import IHaskell.Eval.Widgets import IHaskell.Eval.Widgets
import qualified IHaskell.IPython.Message.UUID as U import IHaskell.IPython.Message.UUID as U
import IHaskell.Display.Widgets.Common import IHaskell.Display.Widgets.Types
data LatexWidget = -- | A 'LatexWidget' represents a Latex widget from IPython.html.widgets.
LatexWidget type LatexWidget = Widget LatexType
{ uuid :: U.UUID
, value :: IORef Text
, description :: IORef Text
, placeholder :: IORef Text
, width :: IORef Int
}
-- | Create a new Latex widget -- | Create a new Latex widget
mkLatexWidget :: IO LatexWidget mkLatexWidget :: IO LatexWidget
mkLatexWidget = do mkLatexWidget = do
-- Default properties, with a random uuid -- Default properties, with a random uuid
commUUID <- U.random uuid <- U.random
val <- newIORef "" let widgetState = WidgetState $ defaultStringWidget "LatexView"
des <- newIORef ""
plc <- newIORef ""
width <- newIORef 400
let b = LatexWidget stateIO <- newIORef widgetState
{ uuid = commUUID
, value = val
, description = des
, placeholder = plc
, width = width
}
let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Latex"] let widget = Widget uuid stateIO
initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Latex"]
-- Open a comm for this widget, and store it in the kernel state -- Open a comm for this widget, and store it in the kernel state
widgetSendOpen b initData (toJSON b) widgetSendOpen widget initData $ toJSON widgetState
-- Return the string widget -- Return the widget
return b return widget
-- | Set the Latex string value.
setLatexValue :: LatexWidget -> Text -> IO ()
setLatexValue b txt = do
modify b value txt
update b ["value" .= txt]
-- | Set the Latex description
setLatexDescription :: LatexWidget -> Text -> IO ()
setLatexDescription b txt = do
modify b description txt
update b ["description" .= txt]
-- | Set the Latex placeholder, i.e. text displayed in empty widget
setLatexPlaceholder :: LatexWidget -> Text -> IO ()
setLatexPlaceholder b txt = do
modify b placeholder txt
update b ["placeholder" .= txt]
-- | Set the Latex widget width.
setLatexWidth :: LatexWidget -> Int -> IO ()
setLatexWidth b wid = do
modify b width wid
update b ["width" .= wid]
-- | Get the Latex string value.
getLatexValue :: LatexWidget -> IO Text
getLatexValue = readIORef . value
-- | Get the Latex description value.
getLatexDescription :: LatexWidget -> IO Text
getLatexDescription = readIORef . description
-- | Get the Latex placeholder value.
getLatexPlaceholder :: LatexWidget -> IO Text
getLatexPlaceholder = readIORef . placeholder
-- | Get the Latex widget width.
getLatexWidth :: LatexWidget -> IO Int
getLatexWidth = readIORef . width
instance ToJSON LatexWidget where
toJSON b = object
[ "_view_name" .= str "LatexView"
, "visible" .= True
, "_css" .= object []
, "msg_throttle" .= (3 :: Int)
, "value" .= get value b
]
where
get x y = unsafePerformIO . readIORef . x $ y
instance IHaskellDisplay LatexWidget where instance IHaskellDisplay LatexWidget where
display b = do display b = do
......
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/Text.hs
View file @ 4e6f20e2
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.String.Text ( module IHaskell.Display.Widgets.String.Text (
-- * The Text Widget -- * The Text Widget
TextWidget, TextWidget,
-- * Constructor -- * Constructor
mkTextWidget, mkTextWidget,
-- * Set properties
setTextValue,
setTextDescription,
setTextPlaceholder,
-- * Get properties
getTextValue,
getTextDescription,
getTextPlaceholder,
-- * Submit handling -- * Submit handling
setSubmitHandler,
getSubmitHandler,
triggerSubmit, triggerSubmit,
) where ) where
-- To keep `cabal repl` happy when running from the ihaskell repo -- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude import Prelude
import Control.Monad (when, void) import Control.Monad (when, join)
import Data.Aeson (ToJSON, Value(..), object, toJSON, (.=)) import Data.Aeson
import Data.Aeson.Types (Pair) import qualified Data.HashMap.Strict as Map
import Data.HashMap.Strict as Map import Data.IORef (newIORef)
import Data.IORef
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import Data.Vinyl (Rec (..), (<+>))
import System.IO.Unsafe (unsafePerformIO)
import IHaskell.Display import IHaskell.Display hiding (Widget)
import IHaskell.Eval.Widgets import IHaskell.Eval.Widgets
import qualified IHaskell.IPython.Message.UUID as U import IHaskell.IPython.Message.UUID as U
import IHaskell.Display.Widgets.Types
import IHaskell.Display.Widgets.Common import IHaskell.Display.Widgets.Common
data TextWidget = -- | A 'TextWidget' represents a Text widget from IPython.html.widgets.
TextWidget type TextWidget = Widget TextType
{ uuid :: U.UUID
, value :: IORef Text
, description :: IORef Text
, placeholder :: IORef Text
, submitHandler :: IORef (TextWidget -> IO ())
}
-- | Create a new Text widget -- | Create a new Text widget
mkTextWidget :: IO TextWidget mkTextWidget :: IO TextWidget
mkTextWidget = do mkTextWidget = do
-- Default properties, with a random uuid -- Default properties, with a random uuid
commUUID <- U.random uuid <- U.random
val <- newIORef "" let strWidget = defaultStringWidget "TextView"
des <- newIORef "" txtWidget = (SSubmitHandler =:: return ()) :& RNil
plc <- newIORef "" widgetState = WidgetState $ strWidget <+> txtWidget
sh <- newIORef $ const $ return ()
let b = TextWidget stateIO <- newIORef widgetState
{ uuid = commUUID
, value = val
, description = des
, placeholder = plc
, submitHandler = sh
}
let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Text"] let widget = Widget uuid stateIO
initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Text"]
-- Open a comm for this widget, and store it in the kernel state -- Open a comm for this widget, and store it in the kernel state
widgetSendOpen b initData (toJSON b) widgetSendOpen widget initData $ toJSON widgetState
-- Return the string widget -- Return the widget
return b return widget
-- | Set the Text string value.
setTextValue :: TextWidget -> Text -> IO ()
setTextValue b txt = do
modify b value txt
update b ["value" .= txt]
-- | Set the text widget "description"
setTextDescription :: TextWidget -> Text -> IO ()
setTextDescription b txt = do
modify b description txt
update b ["description" .= txt]
-- | Set the text widget "placeholder", i.e. text displayed in empty text widget
setTextPlaceholder :: TextWidget -> Text -> IO ()
setTextPlaceholder b txt = do
modify b placeholder txt
update b ["placeholder" .= txt]
-- | Get the Text string value.
getTextValue :: TextWidget -> IO Text
getTextValue = readIORef . value
-- | Get the Text widget "description" value.
getTextDescription :: TextWidget -> IO Text
getTextDescription = readIORef . description
-- | Get the Text widget placeholder value.
getTextPlaceholder :: TextWidget -> IO Text
getTextPlaceholder = readIORef . placeholder
-- | Set a function to be activated on click
setSubmitHandler :: TextWidget -> (TextWidget -> IO ()) -> IO ()
setSubmitHandler = writeIORef . submitHandler
-- | Get the submit handler for a TextWidget
getSubmitHandler :: TextWidget -> IO (TextWidget -> IO ())
getSubmitHandler = readIORef . submitHandler
-- | Artificially trigger a TextWidget submit
triggerSubmit :: TextWidget -> IO () triggerSubmit :: TextWidget -> IO ()
triggerSubmit tw = do triggerSubmit tw = join $ getField tw SSubmitHandler
handler <- getSubmitHandler tw
handler tw
instance ToJSON TextWidget where
toJSON b = object
[ "_view_name" .= str "TextView"
, "visible" .= True
, "_css" .= object []
, "msg_throttle" .= (3 :: Int)
, "value" .= get value b
, "description" .= get description b
, "placeholder" .= get placeholder b
]
where
get x y = unsafePerformIO . readIORef . x $ y
instance IHaskellDisplay TextWidget where instance IHaskellDisplay TextWidget where
display b = do display b = do
...@@ -141,7 +67,7 @@ instance IHaskellWidget TextWidget where ...@@ -141,7 +67,7 @@ instance IHaskellWidget TextWidget where
case Map.lookup "sync_data" dict1 of case Map.lookup "sync_data" dict1 of
Just (Object dict2) -> Just (Object dict2) ->
case Map.lookup "value" dict2 of case Map.lookup "value" dict2 of
Just (String val) -> setTextValue tw val Just (String val) -> setField' tw SStringValue val
Nothing -> return () Nothing -> return ()
Nothing -> Nothing ->
case Map.lookup "content" dict1 of case Map.lookup "content" dict1 of
......
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/TextArea.hs
View file @ 4e6f20e2
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.String.TextArea ( module IHaskell.Display.Widgets.String.TextArea (
-- * The TextArea Widget -- * The TextArea Widget
TextAreaWidget, TextAreaWidget,
-- * Constructor -- * Constructor
mkTextAreaWidget, mkTextAreaWidget,
-- * Set properties
setTextAreaValue,
setTextAreaDescription,
setTextAreaPlaceholder,
-- * Get properties
getTextAreaValue,
getTextAreaDescription,
getTextAreaPlaceholder,
) where ) where
-- To keep `cabal repl` happy when running from the ihaskell repo -- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude import Prelude
import Control.Monad (when) import Control.Monad (when, join)
import Data.Aeson (ToJSON, Value(..), object, toJSON, (.=)) import Data.Aeson
import Data.Aeson.Types (Pair) import Data.IORef (newIORef)
import Data.HashMap.Strict as Map
import Data.IORef
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import Data.Vinyl (Rec (..), (<+>))
import System.IO.Unsafe (unsafePerformIO)
import IHaskell.Display import IHaskell.Display hiding (Widget)
import IHaskell.Eval.Widgets import IHaskell.Eval.Widgets
import qualified IHaskell.IPython.Message.UUID as U import IHaskell.IPython.Message.UUID as U
import IHaskell.Display.Widgets.Common import IHaskell.Display.Widgets.Types
data TextAreaWidget = -- | A 'TextAreaWidget' represents a Textarea widget from IPython.html.widgets.
TextAreaWidget type TextAreaWidget = Widget TextAreaType
{ uuid :: U.UUID
, value :: IORef Text
, description :: IORef Text
, placeholder :: IORef Text
}
-- | Create a new TextArea widget -- | Create a new TextArea widget
mkTextAreaWidget :: IO TextAreaWidget mkTextAreaWidget :: IO TextAreaWidget
mkTextAreaWidget = do mkTextAreaWidget = do
-- Default properties, with a random uuid -- Default properties, with a random uuid
commUUID <- U.random uuid <- U.random
val <- newIORef "" let widgetState = WidgetState $ defaultStringWidget "TextareaView"
des <- newIORef ""
plc <- newIORef ""
let b = TextAreaWidget { uuid = commUUID, value = val, description = des, placeholder = plc } stateIO <- newIORef widgetState
let initData = object let widget = Widget uuid stateIO
["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Textarea"] initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Textarea"]
-- Open a comm for this widget, and store it in the kernel state -- Open a comm for this widget, and store it in the kernel state
widgetSendOpen b initData (toJSON b) widgetSendOpen widget initData $ toJSON widgetState
-- Return the string widget -- Return the widget
return b return widget
-- | Set the TextArea string value.
setTextAreaValue :: TextAreaWidget -> Text -> IO ()
setTextAreaValue b txt = do
modify b value txt
update b ["value" .= txt]
-- | Set the TextArea widget "description"
setTextAreaDescription :: TextAreaWidget -> Text -> IO ()
setTextAreaDescription b txt = do
modify b description txt
update b ["description" .= txt]
-- | Set the TextArea widget "placeholder", i.e. text displayed in empty widget
setTextAreaPlaceholder :: TextAreaWidget -> Text -> IO ()
setTextAreaPlaceholder b txt = do
modify b placeholder txt
update b ["placeholder" .= txt]
-- | Get the TextArea string value.
getTextAreaValue :: TextAreaWidget -> IO Text
getTextAreaValue = readIORef . value
-- | Get the TextArea widget "description" value.
getTextAreaDescription :: TextAreaWidget -> IO Text
getTextAreaDescription = readIORef . description
-- | Get the TextArea widget placeholder value.
getTextAreaPlaceholder :: TextAreaWidget -> IO Text
getTextAreaPlaceholder = readIORef . placeholder
instance ToJSON TextAreaWidget where
toJSON b = object
[ "_view_name" .= str "TextareaView"
, "visible" .= True
, "_css" .= object []
, "msg_throttle" .= (3 :: Int)
, "value" .= get value b
, "description" .= get description b
, "placeholder" .= get placeholder b
]
where
get x y = unsafePerformIO . readIORef . x $ y
instance IHaskellDisplay TextAreaWidget where instance IHaskellDisplay TextAreaWidget where
display b = do display b = do
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment