Commit cc718f3e authored by David Davó's avatar David Davó

Added media widgets

parent f3bbe00b
{
"cells": [
{
"cell_type": "markdown",
"metadata": {},
"source": [
"### The `Image` Widget"
]
},
{
"cell_type": "markdown",
"metadata": {},
"source": [
"This widget can be used to display images given in the form of base64 encoded `Text`. The widget has a `B64Value` field, which can be changed to display images to it. It also has an `ImageFormat` field, which is set to `PNG` by default."
]
},
{
"cell_type": "code",
"execution_count": null,
"metadata": {
"collapsed": true
},
"outputs": [],
"source": [
"{-# LANGUAGE OverloadedStrings #-}\n",
"import IHaskell.Display.Widgets\n",
"import IHaskell.Display (base64, encode64)"
]
},
{
"cell_type": "markdown",
"metadata": {},
"source": [
"The `base64` and `encode64` functions are useful with `ImageWidget`."
]
},
{
"cell_type": "code",
"execution_count": null,
"metadata": {
"collapsed": false
},
"outputs": [],
"source": [
":t base64\n",
":t encode64"
]
},
{
"cell_type": "markdown",
"metadata": {},
"source": [
"The following example downloads an xkcd comic and displays it in an image widget. The example below requires the HTTP package. If you don't have it then you can either install it and restart the ihaskell kernel, or just skip to the next example."
]
},
{
"cell_type": "code",
"execution_count": null,
"metadata": {
"collapsed": false
},
"outputs": [],
"source": [
"import Network.HTTP\n",
"import IHaskell.Display (encode64)\n",
"\n",
"get url = simpleHTTP (getRequest url) >>= getResponseBody\n",
"jpg <- get \"http://imgs.xkcd.com/comics/functional.png\"\n",
"\n",
"img <- mkImageWidget\n",
"setField img B64Value (encode64 jpg)\n",
"img"
]
},
{
"cell_type": "markdown",
"metadata": {},
"source": [
"Replace the call to undefined by the path to an image, and it will be displayed in an image widget."
]
},
{
"cell_type": "code",
"execution_count": null,
"metadata": {
"collapsed": false
},
"outputs": [],
"source": [
"imgpath = undefined\n",
"\n",
"import qualified Data.ByteString as B\n",
"import IHaskell.Display (base64)\n",
"\n",
"i <- mkImageWidget\n",
"B.readFile imgpath >>= setField i B64Value . base64\n",
"\n",
"i"
]
}
],
"metadata": {
"kernelspec": {
"display_name": "Haskell",
"language": "haskell",
"name": "haskell"
},
"language_info": {
"codemirror_mode": "ihaskell",
"file_extension": ".hs",
"name": "haskell",
"version": "7.10.2"
}
},
"nbformat": 4,
"nbformat_minor": 0
}
{
"cells": [
{
"cell_type": "markdown",
"metadata": {},
"source": [
"## The `Media` Widgets\n",
"All the media widgets have a `BSValue`. It's a ByteStream value with the data to display."
]
},
{
"cell_type": "markdown",
"metadata": {},
"source": [
"### The `Image` Widget\n",
"\n",
"This widget can be used to display images, with `ImageFormat` we can set the format of the image. If we set `ImageFormat` to `IURL` and `BSValue` to the utf8-encoded URL, the online image will be displayed automatically."
]
},
{
"cell_type": "code",
"execution_count": 1,
"metadata": {},
"outputs": [
{
"data": {
"text/html": [
"<style>/* Styles used for the Hoogle display in the pager */\n",
".hoogle-doc {\n",
"display: block;\n",
"padding-bottom: 1.3em;\n",
"padding-left: 0.4em;\n",
"}\n",
".hoogle-code {\n",
"display: block;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"}\n",
".hoogle-text {\n",
"display: block;\n",
"}\n",
".hoogle-name {\n",
"color: green;\n",
"font-weight: bold;\n",
"}\n",
".hoogle-head {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-sub {\n",
"display: block;\n",
"margin-left: 0.4em;\n",
"}\n",
".hoogle-package {\n",
"font-weight: bold;\n",
"font-style: italic;\n",
"}\n",
".hoogle-module {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-class {\n",
"font-weight: bold;\n",
"}\n",
".get-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"display: block;\n",
"white-space: pre-wrap;\n",
"}\n",
".show-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"margin-left: 1em;\n",
"}\n",
".mono {\n",
"font-family: monospace;\n",
"display: block;\n",
"}\n",
".err-msg {\n",
"color: red;\n",
"font-style: italic;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"display: block;\n",
"}\n",
"#unshowable {\n",
"color: red;\n",
"font-weight: bold;\n",
"}\n",
".err-msg.in.collapse {\n",
"padding-top: 0.7em;\n",
"}\n",
".highlight-code {\n",
"white-space: pre;\n",
"font-family: monospace;\n",
"}\n",
".suggestion-warning { \n",
"font-weight: bold;\n",
"color: rgb(200, 130, 0);\n",
"}\n",
".suggestion-error { \n",
"font-weight: bold;\n",
"color: red;\n",
"}\n",
".suggestion-name {\n",
"font-weight: bold;\n",
"}\n",
"</style><div class=\"suggestion-name\" style=\"clear:both;\">Unused LANGUAGE pragma</div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Found:</div><div class=\"highlight-code\" id=\"haskell\">{-# LANGUAGE OverloadedStrings #-}</div></div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Why Not:</div><div class=\"highlight-code\" id=\"haskell\"></div></div>"
],
"text/plain": [
"Line 1: Unused LANGUAGE pragma\n",
"Found:\n",
"{-# LANGUAGE OverloadedStrings #-}\n",
"Why not:"
]
},
"metadata": {},
"output_type": "display_data"
}
],
"source": [
"{-# LANGUAGE OverloadedStrings #-}\n",
"import IHaskell.Display.Widgets"
]
},
{
"cell_type": "markdown",
"metadata": {},
"source": [
"First, let's create a function to download data. You'll need to install `http-conduit`."
]
},
{
"cell_type": "code",
"execution_count": 2,
"metadata": {},
"outputs": [],
"source": [
"import Data.Functor ((<&>))\n",
"import Network.HTTP.Simple\n",
"\n",
"get url = httpBS url <&> getResponseBody"
]
},
{
"cell_type": "markdown",
"metadata": {},
"source": [
"Now, let's display a XKCD comic (of course). It's a PNG so we set the image format to PNG."
]
},
{
"cell_type": "code",
"execution_count": 3,
"metadata": {},
"outputs": [
{
"data": {
"application/vnd.jupyter.widget-view+json": {
"model_id": "b82b6c13-f47c-43cf-a801-8dc2f6abcc24",
"version_major": 2,
"version_minor": 0
}
},
"metadata": {},
"output_type": "display_data"
}
],
"source": [
"png <- get \"https://imgs.xkcd.com/comics/haskell.png\"\n",
"img <- mkImageWidget\n",
"setField img ImageFormat PNG\n",
"setField img BSValue png\n",
"img"
]
},
{
"cell_type": "markdown",
"metadata": {},
"source": [
"Let's display another image, but this time setting `ImageFormat` to `IURL`."
]
},
{
"cell_type": "code",
"execution_count": 7,
"metadata": {},
"outputs": [
{
"data": {
"application/vnd.jupyter.widget-view+json": {
"model_id": "cb2129d6-418d-4c05-873b-34befb693555",
"version_major": 2,
"version_minor": 0
}
},
"metadata": {},
"output_type": "display_data"
}
],
"source": [
"imgurl <- mkImageWidget\n",
"setField imgurl ImageFormat IURL\n",
"setField imgurl BSValue \"https://imgs.xkcd.com/comics/functional.png\"\n",
"imgurl"
]
},
{
"cell_type": "markdown",
"metadata": {},
"source": [
"### The `Video` widget\n",
"\n",
"With this widget, we can display video. We are going to display an mp4 file with the first 60 seconds of Big Buck Bunny."
]
},
{
"cell_type": "code",
"execution_count": 5,
"metadata": {},
"outputs": [
{
"data": {
"application/vnd.jupyter.widget-view+json": {
"model_id": "b88a1b8c-a022-47fa-b417-27e63640f3f1",
"version_major": 2,
"version_minor": 0
}
},
"metadata": {},
"output_type": "display_data"
}
],
"source": [
"video <- mkVideoWidget\n",
"mp4 <- get \"http://clips.vorwaerts-gmbh.de/big_buck_bunny.mp4\"\n",
"setField video BSValue mp4\n",
"video"
]
},
{
"cell_type": "markdown",
"metadata": {},
"source": [
"This widget has some more attributes, they are:\n",
"+ `AutoPlay`: Whether to start playing when the video is displayed\n",
"+ `Loop`: Whether to start again the video when it finishes\n",
"+ `Controls`: Whether to display the control overlay on the video\n",
"\n",
"If we wanted to display it directly given the URL, we would need to set the format to `VURL`."
]
},
{
"cell_type": "code",
"execution_count": 6,
"metadata": {},
"outputs": [],
"source": [
"setField video Controls False\n",
"setField video Loop False"
]
},
{
"cell_type": "markdown",
"metadata": {},
"source": [
"### The `Audio` Widget\n",
"Let's do the same, but now with an audio file. It has the same 3 attributes of the video, so we can disable looping and autoplay."
]
},
{
"cell_type": "code",
"execution_count": 12,
"metadata": {},
"outputs": [
{
"data": {
"application/vnd.jupyter.widget-view+json": {
"model_id": "0baa58f4-b663-489d-b18e-af51da067342",
"version_major": 2,
"version_minor": 0
}
},
"metadata": {},
"output_type": "display_data"
}
],
"source": [
"audio <- mkAudioWidget\n",
"setField audio BSValue \"https://file-examples-com.github.io/uploads/2017/11/file_example_MP3_700KB.mp3\"\n",
"setField audio AudioFormat AURL\n",
"setField audio Loop False\n",
"setField audio AutoPlay False\n",
"audio"
]
}
],
"metadata": {
"kernelspec": {
"display_name": "Haskell",
"language": "haskell",
"name": "haskell"
},
"language_info": {
"codemirror_mode": "ihaskell",
"file_extension": ".hs",
"mimetype": "text/x-haskell",
"name": "haskell",
"pygments_lexer": "Haskell",
"version": "8.10.4"
}
},
"nbformat": 4,
"nbformat_minor": 4
}
...@@ -78,7 +78,9 @@ library ...@@ -78,7 +78,9 @@ library
IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider
IHaskell.Display.Widgets.Float.BoundedFloat.FloatLogSlider IHaskell.Display.Widgets.Float.BoundedFloat.FloatLogSlider
IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider
IHaskell.Display.Widgets.Image IHaskell.Display.Widgets.Media.Audio
IHaskell.Display.Widgets.Media.Image
IHaskell.Display.Widgets.Media.Video
IHaskell.Display.Widgets.Output IHaskell.Display.Widgets.Output
IHaskell.Display.Widgets.Selection.Dropdown IHaskell.Display.Widgets.Selection.Dropdown
IHaskell.Display.Widgets.Selection.RadioButtons IHaskell.Display.Widgets.Selection.RadioButtons
...@@ -102,6 +104,7 @@ library ...@@ -102,6 +104,7 @@ library
build-depends: aeson >=0.7 build-depends: aeson >=0.7
, base >=4.9 && <5 , base >=4.9 && <5
, bytestring
, containers >= 0.5 , containers >= 0.5
, ipython-kernel >= 0.6.1.2 , ipython-kernel >= 0.6.1.2
, text >= 0.11 , text >= 0.11
......
...@@ -23,7 +23,9 @@ import IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider as X ...@@ -23,7 +23,9 @@ import IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider as X
import IHaskell.Display.Widgets.Float.BoundedFloat.FloatLogSlider as X import IHaskell.Display.Widgets.Float.BoundedFloat.FloatLogSlider as X
import IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider as X import IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider as X
import IHaskell.Display.Widgets.Image as X import IHaskell.Display.Widgets.Media.Audio as X
import IHaskell.Display.Widgets.Media.Image as X
import IHaskell.Display.Widgets.Media.Video as X
import IHaskell.Display.Widgets.Output as X import IHaskell.Display.Widgets.Output as X
......
...@@ -44,7 +44,7 @@ pattern Placeholder = S.SPlaceholder ...@@ -44,7 +44,7 @@ pattern Placeholder = S.SPlaceholder
pattern Tooltip = S.STooltip pattern Tooltip = S.STooltip
pattern Icon = S.SIcon pattern Icon = S.SIcon
pattern ButtonStyle = S.SButtonStyle pattern ButtonStyle = S.SButtonStyle
pattern B64Value = S.SB64Value pattern BSValue = S.SBSValue
pattern ImageFormat = S.SImageFormat pattern ImageFormat = S.SImageFormat
pattern BoolValue = S.SBoolValue pattern BoolValue = S.SBoolValue
pattern Options = S.SOptions pattern Options = S.SOptions
...@@ -90,6 +90,11 @@ pattern Selector = S.SSelector ...@@ -90,6 +90,11 @@ pattern Selector = S.SSelector
pattern ContinuousUpdate = S.SContinuousUpdate pattern ContinuousUpdate = S.SContinuousUpdate
pattern Tabbable = S.STabbable pattern Tabbable = S.STabbable
pattern Rows = S.SRows pattern Rows = S.SRows
pattern AudioFormat = S.SAudioFormat
pattern VideoFormat = S.SVideoFormat
pattern AutoPlay = S.SAutoPlay
pattern Loop = S.SLoop
pattern Controls = S.SControls
-- | Close a widget's comm -- | Close a widget's comm
closeWidget :: IHaskellWidget w => w -> IO () closeWidget :: IHaskellWidget w => w -> IO ()
...@@ -195,20 +200,52 @@ instance ToJSON BarStyleValue where ...@@ -195,20 +200,52 @@ instance ToJSON BarStyleValue where
toJSON DangerBar = "danger" toJSON DangerBar = "danger"
toJSON DefaultBar = "" toJSON DefaultBar = ""
-- | Audio formats for AudioWidget
data AudioFormatValue = MP3
| OGG
| WAV
| AURL
deriving (Eq, Typeable)
instance Show AudioFormatValue where
show MP3 = "mp3"
show OGG = "ogg"
show WAV = "wav"
show AURL = "url"
instance ToJSON AudioFormatValue where
toJSON = toJSON . pack . show
-- | Image formats for ImageWidget -- | Image formats for ImageWidget
data ImageFormatValue = PNG data ImageFormatValue = PNG
| SVG | SVG
| JPG | JPG
| IURL
deriving (Eq, Typeable) deriving (Eq, Typeable)
instance Show ImageFormatValue where instance Show ImageFormatValue where
show PNG = "png" show PNG = "png"
show SVG = "svg" show SVG = "svg"
show JPG = "jpg" show JPG = "jpg"
show IURL = "url"
instance ToJSON ImageFormatValue where instance ToJSON ImageFormatValue where
toJSON = toJSON . pack . show toJSON = toJSON . pack . show
-- | Video formats for VideoWidget
data VideoFormatValue = MP4
| WEBM
| VURL
deriving (Eq, Typeable)
instance Show VideoFormatValue where
show MP4 = "mp4"
show WEBM = "webm"
show VURL = "url"
instance ToJSON VideoFormatValue where
toJSON = toJSON . pack . show
-- | Options for selection widgets. -- | Options for selection widgets.
data SelectionOptions = OptionLabels [Text] data SelectionOptions = OptionLabels [Text]
| OptionDict [(Text, Text)] | OptionDict [(Text, Text)]
......
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module IHaskell.Display.Widgets.Media.Audio
( -- * The Audio Widget
AudioWidget
-- * Constructor
, mkAudioWidget
) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Data.Aeson
import Data.IORef (newIORef)
import Data.Monoid (mempty)
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
-- | An 'AudioWidget' represents a Audio widget from IPython.html.widgets.
type AudioWidget = IPythonWidget 'AudioType
-- | Create a new audio widget
mkAudioWidget :: IO AudioWidget
mkAudioWidget = do
-- Default properties, with a random uuid
wid <- U.random
let mediaAttrs = defaultMediaWidget "AudioView" "AudioModel"
audioAttrs = (AudioFormat =:: MP3)
:& (AutoPlay =:: True)
:& (Loop =:: True)
:& (Controls =:: True)
:& RNil
widgetState = WidgetState (mediaAttrs <+> audioAttrs)
stateIO <- newIORef widgetState
let widget = IPythonWidget wid stateIO
-- Open a comm for this widget, and store it in the kernel state
widgetSendOpen widget $ toJSON widgetState
-- Return the audio widget
return widget
instance IHaskellWidget AudioWidget where
getCommUUID = uuid
getBufferPaths _ = [["value"]]
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module IHaskell.Display.Widgets.Image module IHaskell.Display.Widgets.Media.Image
( -- * The Image Widget ( -- * The Image Widget
ImageWidget ImageWidget
-- * Constructor -- * Constructor
...@@ -36,13 +36,12 @@ mkImageWidget = do ...@@ -36,13 +36,12 @@ mkImageWidget = do
-- Default properties, with a random uuid -- Default properties, with a random uuid
wid <- U.random wid <- U.random
let dom = defaultDOMWidget "ImageView" "ImageModel" let mediaAttrs = defaultMediaWidget "ImageView" "ImageModel"
img = (ImageFormat =:: PNG) imageAttrs = (ImageFormat =:: PNG)
:& (Width =:+ 0) :& (Width =:+ 0)
:& (Height =:+ 0) :& (Height =:+ 0)
:& (B64Value =:: mempty)
:& RNil :& RNil
widgetState = WidgetState (dom <+> img) widgetState = WidgetState (mediaAttrs <+> imageAttrs)
stateIO <- newIORef widgetState stateIO <- newIORef widgetState
...@@ -56,3 +55,4 @@ mkImageWidget = do ...@@ -56,3 +55,4 @@ mkImageWidget = do
instance IHaskellWidget ImageWidget where instance IHaskellWidget ImageWidget where
getCommUUID = uuid getCommUUID = uuid
getBufferPaths _ = [["value"]]
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module IHaskell.Display.Widgets.Media.Video
( -- * The Video Widget
VideoWidget
-- * Constructor
, mkVideoWidget
) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Data.Aeson
import Data.IORef (newIORef)
import Data.Monoid (mempty)
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
-- | An 'VideoWidget' represents a video widget from IPython.html.widgets.
type VideoWidget = IPythonWidget 'VideoType
-- | Create a new video widget
mkVideoWidget :: IO VideoWidget
mkVideoWidget = do
-- Default properties, with a random uuid
wid <- U.random
let mediaAttrs = defaultMediaWidget "VideoView" "VideoModel"
videoAttrs = (VideoFormat =:: MP4)
:& (Width =:+ 0)
:& (Height =:+ 0)
:& (AutoPlay =:: True)
:& (Loop =:: True)
:& (Controls =:: True)
:& RNil
widgetState = WidgetState (mediaAttrs <+> videoAttrs)
stateIO <- newIORef widgetState
let widget = IPythonWidget wid stateIO
-- Open a comm for this widget, and store it in the kernel state
widgetSendOpen widget $ toJSON widgetState
-- Return the video widget
return widget
instance IHaskellWidget VideoWidget where
getCommUUID = uuid
getBufferPaths _ = [["value"]]
...@@ -50,7 +50,7 @@ singletons ...@@ -50,7 +50,7 @@ singletons
| Tooltip | Tooltip
| Icon | Icon
| ButtonStyle | ButtonStyle
| B64Value | BSValue
| ImageFormat | ImageFormat
| BoolValue | BoolValue
| Options | Options
...@@ -96,5 +96,10 @@ singletons ...@@ -96,5 +96,10 @@ singletons
| ContinuousUpdate | ContinuousUpdate
| Tabbable | Tabbable
| Rows | Rows
| AudioFormat
| VideoFormat
| AutoPlay
| Loop
| Controls
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
|] |]
...@@ -75,6 +75,7 @@ import Text.Printf (printf) ...@@ -75,6 +75,7 @@ import Text.Printf (printf)
import Data.Aeson hiding (pairs) import Data.Aeson hiding (pairs)
import Data.Aeson.Types (Pair) import Data.Aeson.Types (Pair)
import Data.ByteString (ByteString)
import Data.Int (Int16) import Data.Int (Int16)
#if MIN_VERSION_vinyl(0,9,0) #if MIN_VERSION_vinyl(0,9,0)
import Data.Vinyl (Rec(..), Dict(..)) import Data.Vinyl (Rec(..), Dict(..))
...@@ -106,7 +107,7 @@ import Data.Text.Lazy.Encoding ...@@ -106,7 +107,7 @@ import Data.Text.Lazy.Encoding
import GHC.IO.Exception import GHC.IO.Exception
import IHaskell.Eval.Widgets (widgetSendUpdate, widgetSendView) import IHaskell.Eval.Widgets (widgetSendUpdate, widgetSendView)
import IHaskell.Display (Base64, IHaskellWidget(..), IHaskellDisplay(..), Display(..), widgetdisplay) import IHaskell.Display (Base64, IHaskellWidget(..), IHaskellDisplay(..), Display(..), widgetdisplay, base64)
import IHaskell.IPython.Message.UUID import IHaskell.IPython.Message.UUID
import IHaskell.Display.Widgets.Singletons (Field, SField) import IHaskell.Display.Widgets.Singletons (Field, SField)
...@@ -162,6 +163,8 @@ type BoxClass = DOMWidgetClass :++ ['S.Children, 'S.OverflowX, 'S.OverflowY, 'S. ...@@ -162,6 +163,8 @@ type BoxClass = DOMWidgetClass :++ ['S.Children, 'S.OverflowX, 'S.OverflowY, 'S.
type SelectionContainerClass = BoxClass :++ ['S.Titles, 'S.SelectedIndex, 'S.ChangeHandler] type SelectionContainerClass = BoxClass :++ ['S.Titles, 'S.SelectedIndex, 'S.ChangeHandler]
type MediaClass = CoreWidgetClass :++ DOMWidgetClass :++ '[ 'S.BSValue ]
-- Types associated with Fields. -- Types associated with Fields.
type family FieldType (f :: Field) :: * where type family FieldType (f :: Field) :: * where
...@@ -184,7 +187,7 @@ type family FieldType (f :: Field) :: * where ...@@ -184,7 +187,7 @@ type family FieldType (f :: Field) :: * where
FieldType 'S.Tooltip = Maybe Text FieldType 'S.Tooltip = Maybe Text
FieldType 'S.Icon = Text FieldType 'S.Icon = Text
FieldType 'S.ButtonStyle = ButtonStyleValue FieldType 'S.ButtonStyle = ButtonStyleValue
FieldType 'S.B64Value = Base64 FieldType 'S.BSValue = ByteString
FieldType 'S.ImageFormat = ImageFormatValue FieldType 'S.ImageFormat = ImageFormatValue
FieldType 'S.BoolValue = Bool FieldType 'S.BoolValue = Bool
FieldType 'S.Options = SelectionOptions FieldType 'S.Options = SelectionOptions
...@@ -230,6 +233,11 @@ type family FieldType (f :: Field) :: * where ...@@ -230,6 +233,11 @@ type family FieldType (f :: Field) :: * where
FieldType 'S.ContinuousUpdate = Bool FieldType 'S.ContinuousUpdate = Bool
FieldType 'S.Tabbable = Maybe Bool FieldType 'S.Tabbable = Maybe Bool
FieldType 'S.Rows = Maybe Integer FieldType 'S.Rows = Maybe Integer
FieldType 'S.AudioFormat = AudioFormatValue
FieldType 'S.VideoFormat = VideoFormatValue
FieldType 'S.AutoPlay = Bool
FieldType 'S.Loop = Bool
FieldType 'S.Controls = Bool
-- | Can be used to put different widgets in a list. Useful for dealing with children widgets. -- | 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) data ChildWidget = forall w. RecAll Attr (WidgetFields w) ToPairs => ChildWidget (IPythonWidget w)
...@@ -258,7 +266,9 @@ instance CustomBounded Double where ...@@ -258,7 +266,9 @@ instance CustomBounded Double where
-- Different types of widgets. Every widget in IPython has a corresponding WidgetType -- Different types of widgets. Every widget in IPython has a corresponding WidgetType
data WidgetType = ButtonType data WidgetType = ButtonType
| AudioType
| ImageType | ImageType
| VideoType
| OutputType | OutputType
| HTMLType | HTMLType
| HTMLMathType | HTMLMathType
...@@ -296,8 +306,14 @@ type family WidgetFields (w :: WidgetType) :: [Field] where ...@@ -296,8 +306,14 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
WidgetFields 'ButtonType = WidgetFields 'ButtonType =
DescriptionWidgetClass :++ DescriptionWidgetClass :++
['S.Disabled, 'S.Icon, 'S.ButtonStyle ,'S.ClickHandler] ['S.Disabled, 'S.Icon, 'S.ButtonStyle ,'S.ClickHandler]
WidgetFields 'AudioType =
MediaClass :++ ['S.AudioFormat, 'S.AutoPlay, 'S.Loop, 'S.Controls]
WidgetFields 'ImageType = WidgetFields 'ImageType =
DOMWidgetClass :++ ['S.ImageFormat, 'S.Width, 'S.Height, 'S.B64Value] MediaClass :++ ['S.ImageFormat, 'S.Width, 'S.Height]
WidgetFields 'VideoType =
MediaClass :++ ['S.VideoFormat, 'S.Width, 'S.Height, 'S.AutoPlay, 'S.Loop, 'S.Controls]
WidgetFields 'OutputType = DOMWidgetClass WidgetFields 'OutputType = DOMWidgetClass
WidgetFields 'HTMLType = StringClass WidgetFields 'HTMLType = StringClass
WidgetFields 'HTMLMathType = StringClass WidgetFields 'HTMLMathType = StringClass
...@@ -438,12 +454,21 @@ instance ToPairs (Attr 'S.Icon) where ...@@ -438,12 +454,21 @@ instance ToPairs (Attr 'S.Icon) where
instance ToPairs (Attr 'S.ButtonStyle) where instance ToPairs (Attr 'S.ButtonStyle) where
toPairs x = ["button_style" .= toJSON x] toPairs x = ["button_style" .= toJSON x]
instance ToPairs (Attr 'S.B64Value) where instance ToJSON ByteString where
toPairs x = ["_b64value" .= toJSON x] toJSON = toJSON . base64
instance ToPairs (Attr 'S.BSValue) where
toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr 'S.ImageFormat) where instance ToPairs (Attr 'S.ImageFormat) where
toPairs x = ["format" .= toJSON x] toPairs x = ["format" .= toJSON x]
instance ToPairs (Attr 'S.AudioFormat) where
toPairs x = ["format" .= toJSON x]
instance ToPairs (Attr 'S.VideoFormat) where
toPairs x = ["format" .= toJSON x]
instance ToPairs (Attr 'S.BoolValue) where instance ToPairs (Attr 'S.BoolValue) where
toPairs x = ["value" .= toJSON x] toPairs x = ["value" .= toJSON x]
...@@ -582,6 +607,15 @@ instance ToPairs (Attr 'S.Tabbable) where ...@@ -582,6 +607,15 @@ instance ToPairs (Attr 'S.Tabbable) where
instance ToPairs (Attr 'S.Rows) where instance ToPairs (Attr 'S.Rows) where
toPairs x = ["rows" .= toJSON x] toPairs x = ["rows" .= toJSON x]
instance ToPairs (Attr 'S.AutoPlay) where
toPairs x = ["autoplay" .= toJSON x]
instance ToPairs (Attr 'S.Loop) where
toPairs x = ["loop" .= toJSON x]
instance ToPairs (Attr 'S.Controls) where
toPairs x = ["controls" .= toJSON x]
-- | Store the value for a field, as an object parametrized by the Field. No verification is done -- | Store the value for a field, as an object parametrized by the Field. No verification is done
-- for these values. -- for these values.
(=::) :: (SingI f, Typeable (FieldType f)) => Sing f -> FieldType f -> Attr f (=::) :: (SingI f, Typeable (FieldType f)) => Sing f -> FieldType f -> Attr f
...@@ -793,6 +827,13 @@ defaultSelectionContainerWidget viewName modelName = defaultBoxWidget viewName m ...@@ -793,6 +827,13 @@ defaultSelectionContainerWidget viewName modelName = defaultBoxWidget viewName m
:& (ChangeHandler =:: return ()) :& (ChangeHandler =:: return ())
:& RNil :& RNil
-- | A record representing a widget of the _Media class from IPython
defaultMediaWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr MediaClass
defaultMediaWidget viewName modelName = defaultCoreWidget <+> defaultDOMWidget viewName modelName <+> mediaAttrs
where
mediaAttrs = (BSValue =:: "")
:& RNil
newtype WidgetState w = WidgetState { _getState :: Rec Attr (WidgetFields w) } newtype WidgetState w = WidgetState { _getState :: Rec Attr (WidgetFields w) }
-- All records with ToPair instances for their Attrs will automatically have a toJSON instance now. -- All records with ToPair instances for their Attrs will automatically have a toJSON instance now.
......
...@@ -20,6 +20,7 @@ import Control.Monad (foldM) ...@@ -20,6 +20,7 @@ import Control.Monad (foldM)
import Data.Aeson import Data.Aeson
import Data.Aeson.Types (emptyArray) import Data.Aeson.Types (emptyArray)
import Data.ByteString.Lazy (toStrict) import Data.ByteString.Lazy (toStrict)
import Data.ByteString.Base64 as B64 (decodeLenient)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (encodeUtf8)
import Data.HashMap.Strict as HM (lookup,insert,delete) import Data.HashMap.Strict as HM (lookup,insert,delete)
...@@ -204,7 +205,7 @@ handleMessage send replyHeader state msg = do ...@@ -204,7 +205,7 @@ handleMessage send replyHeader state msg = do
f :: (Value, [ByteString], [BufferPath]) -> BufferPath -> (Value, [ByteString], [BufferPath]) f :: (Value, [ByteString], [BufferPath]) -> BufferPath -> (Value, [ByteString], [BufferPath])
f r@(v,bs,bps) bp = f r@(v,bs,bps) bp =
case nestedLookupRemove bp v of case nestedLookupRemove bp v of
(newv, Just (String b)) -> (newv, encodeUtf8 b : bs, bp:bps) (newv, Just (String b)) -> (newv, B64.decodeLenient (encodeUtf8 b) : bs, bp:bps)
_ -> r _ -> r
-- Override toJSON for PublishDisplayData for sending Display messages through [method .= custom] -- Override toJSON for PublishDisplayData for sending Display messages through [method .= custom]
......
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