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 Show 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
-- Modules included in this library but not exported.
other-modules: IHaskell.Display.Widgets.Button
IHaskell.Display.Widgets.Image
IHaskell.Display.Widgets.Dropdown
-- IHaskell.Display.Widgets.Dropdown
IHaskell.Display.Widgets.String.HTML
IHaskell.Display.Widgets.String.Latex
IHaskell.Display.Widgets.String.Text
......@@ -64,6 +64,7 @@ library
IHaskell.Display.Widgets.Output
IHaskell.Display.Widgets.Types
IHaskell.Display.Widgets.Common
-- LANGUAGE extensions used by modules in this package.
-- other-extensions:
......@@ -77,6 +78,7 @@ library
, unordered-containers >= 0.2.5.1
-- TODO: Need to check versions
, vinyl -any
, singletons -any
-- 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
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
......@@ -13,4 +13,5 @@ import IHaskell.Display.Widgets.String.TextArea 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 OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Button (
-- * The Button Widget
......@@ -15,21 +16,18 @@ module IHaskell.Display.Widgets.Button (
import Prelude
import Control.Monad (when, join)
import Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
import Data.Aeson.Types (Pair)
import Data.Map as M
import Data.HashMap.Strict as HashMap
import Data.IORef
import Data.Aeson
import Data.HashMap.Strict as HM
import Data.IORef (newIORef)
import Data.Text (Text)
import qualified Data.Text as T
import System.IO.Unsafe (unsafePerformIO)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display hiding (Widget)
import IHaskell.Eval.Widgets
import qualified IHaskell.IPython.Message.UUID as U
import IHaskell.Types (WidgetMethod(..))
import IHaskell.IPython.Message.UUID as U
import IHaskell.Display.Widgets.Types
import IHaskell.Display.Widgets.Common
-- | A 'Button' represents a Button from IPython.html.widgets.
type Button = Widget ButtonType
......@@ -40,23 +38,27 @@ mkButton = do
-- Default properties, with a random uuid
uuid <- U.random
let dom = domWidgetWith "ButtonView"
but = [ SDescription ~= ""
, STooltip ~= ""
, SDisabled ~= False
, SIcon ~= ""
, SButtonStyle ~= DefaultButton
, SClickHandler ~= return ()
]
attributes = M.fromList $ dom ++ but
let dom = defaultDOMWidget "ButtonView"
but = (SDescription =:: "")
:& (STooltip =:: "")
:& (SDisabled =:: False)
:& (SIcon =:: "")
:& (SButtonStyle =:: DefaultButton)
:& (SClickHandler =:: return ())
:& RNil
buttonState = WidgetState (dom <+> but)
stateIO <- newIORef buttonState
attrIO <- newIORef attributes
let button = Widget uuid stateIO
let button = Widget uuid attrIO :: Widget ButtonType
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
widgetSendOpen button initData $ toJSON button
widgetSendOpen button initData $ toJSON buttonState
-- Return the button widget
return button
......@@ -65,20 +67,6 @@ mkButton = do
triggerClick :: Button -> IO ()
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
display b = do
widgetSendView b
......@@ -89,6 +77,6 @@ instance IHaskellWidget Button where
comm widget (Object dict1) _ = do
let key1 = "content" :: Text
key2 = "event" :: Text
Just (Object dict2) = HashMap.lookup key1 dict1
Just (String event) = HashMap.lookup key2 dict2
Just (Object dict2) = HM.lookup key1 dict1
Just (String event) = HM.lookup key2 dict2
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 FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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
module IHaskell.Display.Widgets.Common (
-- * Convenience types
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.Eval.Widgets (widgetSendUpdate)
import IHaskell.Display (Base64, IHaskellWidget (..))
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 }
-- 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 = ""
instance ToJSON PosInt where
toJSON (PosInt n)
| n > 0 = toJSON $ str $ show n
| otherwise = toJSON $ str $ ""
-- | Image formats for ImageWidget
data ImageFormatValue = PNG
| SVG
| JPG
deriving Eq
-- | 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
instance Show ImageFormatValue where
show PNG = "png"
show SVG = "svg"
show JPG = "jpg"
-- | 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
instance ToJSON ImageFormatValue where
toJSON = toJSON . pack . show
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Image.hs
View file @ 4e6f20e2
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Image (
-- * The Image Widget
ImageWidget,
-- * Create a new image widget
-- * Constructor
mkImageWidget,
-- * Set image properties
setImageFormat,
setImageB64Value,
setImageWidth,
setImageHeight,
-- * Get image properties
getImageFormat,
getImageB64Value,
getImageWidth,
getImageHeight,
) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when)
import Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
import Data.Aeson.Types (Pair)
import Data.HashMap.Strict as Map
import Data.IORef
import Control.Monad (when, join)
import Data.Aeson
import Data.HashMap.Strict as HM
import Data.IORef (newIORef)
import Data.Text (Text)
import qualified Data.Text as T
import System.IO.Unsafe (unsafePerformIO)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display
import IHaskell.Display hiding (Widget)
import IHaskell.Eval.Widgets
import qualified IHaskell.IPython.Message.UUID as U
import IHaskell.Types (WidgetMethod(..))
import IHaskell.IPython.Message.UUID as U
import IHaskell.Display.Widgets.Types
import IHaskell.Display.Widgets.Common
-- | A 'Image' represents a Image from IPython.html.widgets.
data ImageWidget =
ImageWidget
{ uuid :: U.UUID
, format :: IORef ImageFormat
, height :: IORef PosInt
, width :: IORef PosInt
, b64value :: IORef Base64
}
-- | An 'ImageWidget' represents a Image widget from IPython.html.widgets.
type ImageWidget = Widget ImageType
-- | Create a new image widget
mkImageWidget :: IO ImageWidget
mkImageWidget = do
-- Default properties, with a random uuid
commUUID <- U.random
fmt <- newIORef PNG
hgt <- newIORef (PosInt 0)
wdt <- newIORef (PosInt 0)
val <- newIORef ""
uuid <- U.random
let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Image"]
b = ImageWidget { uuid = commUUID, format = fmt, height = hgt, width = wdt, b64value = val }
let dom = defaultDOMWidget "ImageView"
img = (SImageFormat =:: PNG)
:& (SB64Value =:: mempty)
:& RNil
widgetState = WidgetState (dom <+> img)
-- Open a comm for this widget, and store it in the kernel state
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
setImageWidth :: ImageWidget -> Int -> IO ()
setImageWidth b wdt = do
let w = PosInt wdt
modify b width w
update b ["width" .= w]
stateIO <- newIORef widgetState
-- | Set the image height
setImageHeight :: ImageWidget -> Int -> IO ()
setImageHeight b hgt = do
let h = PosInt hgt
modify b height h
update b ["height" .= h]
let widget = Widget uuid stateIO
-- | Get the image format
getImageFormat :: ImageWidget -> IO ImageFormat
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
let initData = object
[ "model_name" .= str "WidgetModel"
, "widget_class" .= str "IPython.Image"
]
-- | Get the image height
getImageHeight :: ImageWidget -> IO Int
getImageHeight = fmap unwrap . readIORef . height
-- Open a comm for this widget, and store it in the kernel state
widgetSendOpen widget initData $ toJSON widgetState
instance ToJSON ImageWidget 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" .= 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
-- Return the image widget
return widget
instance IHaskellDisplay ImageWidget where
display b = do
......
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Output.hs
View file @ 4e6f20e2
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Output (
-- * The Output Widget
OutputWidget,
-- * Constructor
mkOutputWidget,
-- * Get/Set/Modify width
getOutputWidth,
setOutputWidth,
modifyOutputWidth,
modifyOutputWidth_,
-- * Output to widget
-- * Using the output widget
appendOutput,
clearOutput,
clearOutput_,
......@@ -21,62 +18,40 @@ module IHaskell.Display.Widgets.Output (
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when, void)
import Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
import Data.Aeson.Types (Pair, Array)
import qualified Data.HashMap.Strict as Map
import Data.IORef
import Control.Monad (when, join)
import Data.Aeson
import Data.HashMap.Strict as HM
import Data.IORef (newIORef)
import Data.Text (Text)
import qualified Data.Text as T
import System.IO.Unsafe (unsafePerformIO)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display
import IHaskell.Display hiding (Widget)
import IHaskell.Eval.Widgets
import qualified IHaskell.IPython.Message.UUID as U
import IHaskell.Types (WidgetMethod(..))
import IHaskell.IPython.Message.UUID as U
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 = do
-- Default properties, with a random uuid
commUUID <- U.random
wdt <- newIORef $ PosInt 400
dis <- newIORef False
uuid <- U.random
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
widgetSendOpen b initData (toJSON b)
-- Return the widget
return b
-- | Get the output widget width
getOutputWidth :: OutputWidget -> IO Int
getOutputWidth = fmap unwrap . readIORef . width
let widget = Widget uuid stateIO
initData = object ["model_name" .= str "WidgetModel"]
-- | Set the output widget width
setOutputWidth :: OutputWidget -> Int -> IO ()
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
-- Open a comm for this widget, and store it in the kernel state
widgetSendOpen widget initData $ toJSON widgetState
-- | Modify the output widget width (with pure modifier)
modifyOutputWidth_ :: OutputWidget -> (Int -> Int) -> IO ()
modifyOutputWidth_ widget modifier = do
w <- getOutputWidth widget
let newWidth = modifier w
setOutputWidth widget newWidth
-- Return the image widget
return widget
-- | Append to the output widget
appendOutput :: IHaskellDisplay a => OutputWidget -> a -> IO ()
......@@ -98,33 +73,6 @@ replaceOutput widget d = do
clearOutput_ widget
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
display b = do
widgetSendView b
......
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/HTML.hs
View file @ 4e6f20e2
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.String.HTML (
-- * The HTML Widget
HTMLWidget,
-- * Constructor
mkHTMLWidget,
-- * Set properties
setHTMLValue,
setHTMLDescription,
setHTMLPlaceholder,
-- * Get properties
getHTMLValue,
getHTMLDescription,
getHTMLPlaceholder,
) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when)
import Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
import Data.Aeson.Types (Pair)
import Data.HashMap.Strict as Map
import Data.IORef
import Control.Monad (when, join)
import Data.Aeson
import Data.IORef (newIORef)
import Data.Text (Text)
import qualified Data.Text as T
import System.IO.Unsafe (unsafePerformIO)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display
import IHaskell.Display hiding (Widget)
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 =
HTMLWidget
{ uuid :: U.UUID
, value :: IORef Text
, description :: IORef Text
, placeholder :: IORef Text
}
-- | A 'HTMLWidget' represents a HTML widget from IPython.html.widgets.
type HTMLWidget = Widget HTMLType
-- | Create a new HTML widget
mkHTMLWidget :: IO HTMLWidget
mkHTMLWidget = do
-- Default properties, with a random uuid
commUUID <- U.random
val <- newIORef ""
des <- newIORef ""
plc <- newIORef ""
uuid <- U.random
let widgetState = WidgetState $ defaultStringWidget "HTMLView"
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
widgetSendOpen b initData (toJSON b)
widgetSendOpen widget initData $ toJSON widgetState
-- Return the string widget
return b
-- | 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
-- Return the widget
return widget
instance IHaskellDisplay HTMLWidget where
display b = do
......
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/Latex.hs
View file @ 4e6f20e2
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.String.Latex (
-- * The Latex Widget
LatexWidget,
-- * Constructor
mkLatexWidget,
-- * Set properties
setLatexValue,
setLatexPlaceholder,
setLatexDescription,
setLatexWidth,
-- * Get properties
getLatexValue,
getLatexPlaceholder,
getLatexDescription,
getLatexWidth,
) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when)
import Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
import Data.Aeson.Types (Pair)
import Data.HashMap.Strict as Map
import Data.IORef
import Control.Monad (when, join)
import Data.Aeson
import Data.IORef (newIORef)
import Data.Text (Text)
import qualified Data.Text as T
import System.IO.Unsafe (unsafePerformIO)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display
import IHaskell.Display hiding (Widget)
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 =
LatexWidget
{ uuid :: U.UUID
, value :: IORef Text
, description :: IORef Text
, placeholder :: IORef Text
, width :: IORef Int
}
-- | A 'LatexWidget' represents a Latex widget from IPython.html.widgets.
type LatexWidget = Widget LatexType
-- | Create a new Latex widget
mkLatexWidget :: IO LatexWidget
mkLatexWidget = do
-- Default properties, with a random uuid
commUUID <- U.random
val <- newIORef ""
des <- newIORef ""
plc <- newIORef ""
width <- newIORef 400
uuid <- U.random
let widgetState = WidgetState $ defaultStringWidget "LatexView"
let b = LatexWidget
{ uuid = commUUID
, value = val
, description = des
, placeholder = plc
, width = width
}
stateIO <- newIORef widgetState
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
widgetSendOpen b initData (toJSON b)
widgetSendOpen widget initData $ toJSON widgetState
-- Return the string widget
return b
-- | 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
-- Return the widget
return widget
instance IHaskellDisplay LatexWidget where
display b = do
......
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/Text.hs
View file @ 4e6f20e2
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.String.Text (
-- * The Text Widget
TextWidget,
-- * Constructor
mkTextWidget,
-- * Set properties
setTextValue,
setTextDescription,
setTextPlaceholder,
-- * Get properties
getTextValue,
getTextDescription,
getTextPlaceholder,
-- * Submit handling
setSubmitHandler,
getSubmitHandler,
triggerSubmit,
) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when, void)
import Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
import Data.Aeson.Types (Pair)
import Data.HashMap.Strict as Map
import Data.IORef
import Control.Monad (when, join)
import Data.Aeson
import qualified Data.HashMap.Strict as Map
import Data.IORef (newIORef)
import Data.Text (Text)
import qualified Data.Text as T
import System.IO.Unsafe (unsafePerformIO)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display
import IHaskell.Display hiding (Widget)
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
data TextWidget =
TextWidget
{ uuid :: U.UUID
, value :: IORef Text
, description :: IORef Text
, placeholder :: IORef Text
, submitHandler :: IORef (TextWidget -> IO ())
}
-- | A 'TextWidget' represents a Text widget from IPython.html.widgets.
type TextWidget = Widget TextType
-- | Create a new Text widget
mkTextWidget :: IO TextWidget
mkTextWidget = do
-- Default properties, with a random uuid
commUUID <- U.random
val <- newIORef ""
des <- newIORef ""
plc <- newIORef ""
sh <- newIORef $ const $ return ()
uuid <- U.random
let strWidget = defaultStringWidget "TextView"
txtWidget = (SSubmitHandler =:: return ()) :& RNil
widgetState = WidgetState $ strWidget <+> txtWidget
let b = TextWidget
{ uuid = commUUID
, value = val
, description = des
, placeholder = plc
, submitHandler = sh
}
stateIO <- newIORef widgetState
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
widgetSendOpen b initData (toJSON b)
widgetSendOpen widget initData $ toJSON widgetState
-- Return the string widget
return b
-- Return the widget
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 tw = do
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
triggerSubmit tw = join $ getField tw SSubmitHandler
instance IHaskellDisplay TextWidget where
display b = do
......@@ -141,7 +67,7 @@ instance IHaskellWidget TextWidget where
case Map.lookup "sync_data" dict1 of
Just (Object dict2) ->
case Map.lookup "value" dict2 of
Just (String val) -> setTextValue tw val
Just (String val) -> setField' tw SStringValue val
Nothing -> return ()
Nothing ->
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 DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.String.TextArea (
-- * The TextArea Widget
TextAreaWidget,
-- * Constructor
mkTextAreaWidget,
-- * Set properties
setTextAreaValue,
setTextAreaDescription,
setTextAreaPlaceholder,
-- * Get properties
getTextAreaValue,
getTextAreaDescription,
getTextAreaPlaceholder,
) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when)
import Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
import Data.Aeson.Types (Pair)
import Data.HashMap.Strict as Map
import Data.IORef
import Control.Monad (when, join)
import Data.Aeson
import Data.IORef (newIORef)
import Data.Text (Text)
import qualified Data.Text as T
import System.IO.Unsafe (unsafePerformIO)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display
import IHaskell.Display hiding (Widget)
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 =
TextAreaWidget
{ uuid :: U.UUID
, value :: IORef Text
, description :: IORef Text
, placeholder :: IORef Text
}
-- | A 'TextAreaWidget' represents a Textarea widget from IPython.html.widgets.
type TextAreaWidget = Widget TextAreaType
-- | Create a new TextArea widget
mkTextAreaWidget :: IO TextAreaWidget
mkTextAreaWidget = do
-- Default properties, with a random uuid
commUUID <- U.random
val <- newIORef ""
des <- newIORef ""
plc <- newIORef ""
uuid <- U.random
let widgetState = WidgetState $ defaultStringWidget "TextareaView"
let b = TextAreaWidget { uuid = commUUID, value = val, description = des, placeholder = plc }
stateIO <- newIORef widgetState
let initData = object
["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Textarea"]
let widget = Widget uuid stateIO
initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Textarea"]
-- 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 b
-- | 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
-- Return the widget
return widget
instance IHaskellDisplay TextAreaWidget where
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