{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules, CPP #-}
module IHaskell.Eval.Widgets (
    widgetSendOpen,
    widgetSendView,
    widgetSendUpdate,
    widgetSendCustom,
    widgetSendClose,
    widgetSendValue,
    widgetPublishDisplay,
    widgetClearOutput,
    relayWidgetMessages,
    widgetHandler,
    ) where

import           IHaskellPrelude

import           Control.Concurrent.STM (atomically)
import           Control.Concurrent.STM.TChan
import           Data.Aeson
import           Data.ByteString.Base64 as B64 (decodeLenient)
import qualified Data.Map as Map
import           Data.Text.Encoding (encodeUtf8)

import           Data.Foldable (foldl)
import           System.IO.Unsafe (unsafePerformIO)

import           IHaskell.Display
import           IHaskell.Eval.Util (unfoldM)
import           IHaskell.IPython.Types (showMessageType)
import           IHaskell.Types

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KM (lookup,insert,delete)
import qualified Data.Aeson.Key    as Key
#else
import qualified Data.HashMap.Strict as HM (lookup,insert,delete)
#endif

-- All comm_open messages go here
widgetMessages :: TChan WidgetMsg
{-# NOINLINE widgetMessages #-}
widgetMessages :: TChan WidgetMsg
widgetMessages = IO (TChan WidgetMsg) -> TChan WidgetMsg
forall a. IO a -> a
unsafePerformIO IO (TChan WidgetMsg)
forall a. IO (TChan a)
newTChanIO

-- | Return all pending comm_close messages
relayWidgetMessages :: IO [WidgetMsg]
relayWidgetMessages :: IO [WidgetMsg]
relayWidgetMessages = TChan WidgetMsg -> IO [WidgetMsg]
forall a. TChan a -> IO [a]
relayMessages TChan WidgetMsg
widgetMessages

-- | Extract all messages from a TChan and wrap them in a list
relayMessages :: TChan a -> IO [a]
relayMessages :: forall a. TChan a -> IO [a]
relayMessages = IO (Maybe a) -> IO [a]
forall a. IO (Maybe a) -> IO [a]
unfoldM (IO (Maybe a) -> IO [a])
-> (TChan a -> IO (Maybe a)) -> TChan a -> IO [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically (STM (Maybe a) -> IO (Maybe a))
-> (TChan a -> STM (Maybe a)) -> TChan a -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan a -> STM (Maybe a)
forall a. TChan a -> STM (Maybe a)
tryReadTChan

-- | Write a widget message to the chan
queue :: WidgetMsg -> IO ()
queue :: WidgetMsg -> IO ()
queue = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (WidgetMsg -> STM ()) -> WidgetMsg -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan WidgetMsg -> WidgetMsg -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan WidgetMsg
widgetMessages

-- | Send a message
widgetSend :: IHaskellWidget a
           => (Widget -> Value -> WidgetMsg)
           -> a -> Value -> IO ()
widgetSend :: forall a.
IHaskellWidget a =>
(Widget -> Value -> WidgetMsg) -> a -> Value -> IO ()
widgetSend Widget -> Value -> WidgetMsg
mtype a
widget Value
value = WidgetMsg -> IO ()
queue (WidgetMsg -> IO ()) -> WidgetMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ Widget -> Value -> WidgetMsg
mtype (a -> Widget
forall a. IHaskellWidget a => a -> Widget
Widget a
widget) Value
value

-- | Send a message to open a comm
widgetSendOpen :: IHaskellWidget a => a -> Value -> IO ()
widgetSendOpen :: forall a. IHaskellWidget a => a -> Value -> IO ()
widgetSendOpen = (Widget -> Value -> WidgetMsg) -> a -> Value -> IO ()
forall a.
IHaskellWidget a =>
(Widget -> Value -> WidgetMsg) -> a -> Value -> IO ()
widgetSend Widget -> Value -> WidgetMsg
Open

-- | Send a state update message
widgetSendUpdate :: IHaskellWidget a => a -> Value -> IO ()
widgetSendUpdate :: forall a. IHaskellWidget a => a -> Value -> IO ()
widgetSendUpdate = (Widget -> Value -> WidgetMsg) -> a -> Value -> IO ()
forall a.
IHaskellWidget a =>
(Widget -> Value -> WidgetMsg) -> a -> Value -> IO ()
widgetSend Widget -> Value -> WidgetMsg
Update

-- | Send a [method .= display] comm_msg
widgetSendView :: IHaskellWidget a => a -> IO ()
widgetSendView :: forall a. IHaskellWidget a => a -> IO ()
widgetSendView = WidgetMsg -> IO ()
queue (WidgetMsg -> IO ()) -> (a -> WidgetMsg) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Widget -> WidgetMsg
View (Widget -> WidgetMsg) -> (a -> Widget) -> a -> WidgetMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Widget
forall a. IHaskellWidget a => a -> Widget
Widget

-- | Send a comm_close
widgetSendClose :: IHaskellWidget a => a -> Value -> IO ()
widgetSendClose :: forall a. IHaskellWidget a => a -> Value -> IO ()
widgetSendClose = (Widget -> Value -> WidgetMsg) -> a -> Value -> IO ()
forall a.
IHaskellWidget a =>
(Widget -> Value -> WidgetMsg) -> a -> Value -> IO ()
widgetSend Widget -> Value -> WidgetMsg
Close

-- | Send a [method .= custom, content .= value] comm_msg
widgetSendCustom :: IHaskellWidget a => a -> Value -> IO ()
widgetSendCustom :: forall a. IHaskellWidget a => a -> Value -> IO ()
widgetSendCustom = (Widget -> Value -> WidgetMsg) -> a -> Value -> IO ()
forall a.
IHaskellWidget a =>
(Widget -> Value -> WidgetMsg) -> a -> Value -> IO ()
widgetSend Widget -> Value -> WidgetMsg
Custom

-- | Send a custom Value
widgetSendValue :: IHaskellWidget a => a -> Value -> IO ()
widgetSendValue :: forall a. IHaskellWidget a => a -> Value -> IO ()
widgetSendValue a
widget = WidgetMsg -> IO ()
queue (WidgetMsg -> IO ()) -> (Value -> WidgetMsg) -> Value -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Widget -> Value -> WidgetMsg
JSONValue (a -> Widget
forall a. IHaskellWidget a => a -> Widget
Widget a
widget)

-- | Send a `display_data` message as a [method .= custom] message
widgetPublishDisplay :: (IHaskellWidget a, IHaskellDisplay b) => a -> b -> IO ()
widgetPublishDisplay :: forall a b.
(IHaskellWidget a, IHaskellDisplay b) =>
a -> b -> IO ()
widgetPublishDisplay a
widget b
disp = b -> IO Display
forall a. IHaskellDisplay a => a -> IO Display
display b
disp IO Display -> (Display -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WidgetMsg -> IO ()
queue (WidgetMsg -> IO ()) -> (Display -> WidgetMsg) -> Display -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Widget -> Display -> WidgetMsg
DispMsg (a -> Widget
forall a. IHaskellWidget a => a -> Widget
Widget a
widget)

-- | Send a `clear_output` message
widgetClearOutput :: Bool -> IO ()
widgetClearOutput :: Bool -> IO ()
widgetClearOutput Bool
w = WidgetMsg -> IO ()
queue (WidgetMsg -> IO ()) -> WidgetMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> WidgetMsg
ClrOutput Bool
w

-- | Handle a single widget message. Takes necessary actions according to the message type, such as
-- opening comms, storing and updating widget representation in the kernel state etc.
handleMessage :: (Message -> IO ())
              -> MessageHeader
              -> KernelState
              -> WidgetMsg
              -> IO KernelState
handleMessage :: (Message -> IO ())
-> MessageHeader -> KernelState -> WidgetMsg -> IO KernelState
handleMessage Message -> IO ()
send MessageHeader
replyHeader KernelState
state WidgetMsg
msg = do
  case WidgetMsg
msg of
    Open Widget
widget Value
value -> do
      let target_name :: String
target_name = Widget -> String
forall a. IHaskellWidget a => a -> String
targetName Widget
widget
          target_module :: String
target_module = Widget -> String
forall a. IHaskellWidget a => a -> String
targetModule Widget
widget
          uuid :: UUID
uuid = Widget -> UUID
forall a. IHaskellWidget a => a -> UUID
getCommUUID Widget
widget
          present :: Bool
present = Maybe Widget -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Widget -> Bool) -> Maybe Widget -> Bool
forall a b. (a -> b) -> a -> b
$ UUID -> Map UUID Widget -> Maybe Widget
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UUID
uuid Map UUID Widget
oldComms

          newComms :: Map UUID Widget
newComms = UUID -> Widget -> Map UUID Widget -> Map UUID Widget
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert UUID
uuid Widget
widget Map UUID Widget
oldComms
          newState :: KernelState
newState = KernelState
state { openComms = newComms }

          (Value
newvalue,[ByteString]
buffers,[BufferPath]
bp) = Value -> [BufferPath] -> (Value, [ByteString], [BufferPath])
processBPs Value
value ([BufferPath] -> (Value, [ByteString], [BufferPath]))
-> [BufferPath] -> (Value, [ByteString], [BufferPath])
forall a b. (a -> b) -> a -> b
$ Widget -> [BufferPath]
forall a. IHaskellWidget a => a -> [BufferPath]
getBufferPaths Widget
widget
          applyBuffers :: MessageHeader -> MessageHeader
applyBuffers MessageHeader
x = MessageHeader
x {mhBuffers = buffers}
          content :: Value
content = [Pair] -> Value
object [ Key
"state" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
newvalue, Key
"buffer_paths" Key -> [BufferPath] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [BufferPath]
bp ]

          communicate :: Value -> IO ()
communicate Value
val = do
            MessageHeader
head <- MessageHeader -> MessageHeader
applyBuffers (MessageHeader -> MessageHeader)
-> IO MessageHeader -> IO MessageHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MessageHeader -> MessageType -> IO MessageHeader
dupHeader MessageHeader
replyHeader MessageType
CommDataMessage
            Message -> IO ()
send (Message -> IO ()) -> Message -> IO ()
forall a b. (a -> b) -> a -> b
$ MessageHeader -> UUID -> Value -> Message
CommData MessageHeader
head UUID
uuid Value
val

      -- If the widget is present, don't open it again.
      if Bool
present
        then KernelState -> IO KernelState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return KernelState
state
        else do
          -- Send the comm open, with the initial state
          MessageHeader
hdr <- MessageHeader -> MessageHeader
applyBuffers (MessageHeader -> MessageHeader)
-> IO MessageHeader -> IO MessageHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MessageHeader -> MessageType -> IO MessageHeader
dupHeader MessageHeader
replyHeader MessageType
CommOpenMessage
          let hdrV :: MessageHeader
hdrV = MessageHeader -> String -> MessageHeader
setVersion MessageHeader
hdr String
"2.0.0" -- Widget Messaging Protocol Version
          Message -> IO ()
send (Message -> IO ()) -> Message -> IO ()
forall a b. (a -> b) -> a -> b
$ MessageHeader -> String -> String -> UUID -> Value -> Message
CommOpen MessageHeader
hdrV String
target_name String
target_module UUID
uuid Value
content

          -- Send anything else the widget requires.
          Widget -> (Value -> IO ()) -> IO ()
forall a. IHaskellWidget a => a -> (Value -> IO ()) -> IO ()
open Widget
widget Value -> IO ()
communicate

          -- Store the widget in the kernelState
          KernelState -> IO KernelState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return KernelState
newState

    Close Widget
widget Value
value -> do
      let uuid :: UUID
uuid = Widget -> UUID
forall a. IHaskellWidget a => a -> UUID
getCommUUID Widget
widget
          present :: Bool
present = Maybe Widget -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Widget -> Bool) -> Maybe Widget -> Bool
forall a b. (a -> b) -> a -> b
$ UUID -> Map UUID Widget -> Maybe Widget
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UUID
uuid Map UUID Widget
oldComms

          newComms :: Map UUID Widget
newComms = UUID -> Map UUID Widget -> Map UUID Widget
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete UUID
uuid (Map UUID Widget -> Map UUID Widget)
-> Map UUID Widget -> Map UUID Widget
forall a b. (a -> b) -> a -> b
$ KernelState -> Map UUID Widget
openComms KernelState
state
          newState :: KernelState
newState = KernelState
state { openComms = newComms }

      -- If the widget is not present in the state, we don't close it.
      if Bool
present
        then do
          MessageHeader
hdr <- MessageHeader -> MessageType -> IO MessageHeader
dupHeader MessageHeader
replyHeader MessageType
CommCloseMessage
          Message -> IO ()
send (Message -> IO ()) -> Message -> IO ()
forall a b. (a -> b) -> a -> b
$ MessageHeader -> UUID -> Value -> Message
CommClose MessageHeader
hdr UUID
uuid Value
value
          KernelState -> IO KernelState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return KernelState
newState
        else KernelState -> IO KernelState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return KernelState
state

    View Widget
widget -> Widget -> Value -> IO KernelState
forall {p}. IHaskellWidget p => p -> Value -> IO KernelState
sendMessage Widget
widget (WidgetMethod -> Value
forall a. ToJSON a => a -> Value
toJSON WidgetMethod
DisplayWidget)

    Update Widget
widget Value
value -> do
      let (Value
newvalue,[ByteString]
buffers,[BufferPath]
bp) = Value -> [BufferPath] -> (Value, [ByteString], [BufferPath])
processBPs Value
value ([BufferPath] -> (Value, [ByteString], [BufferPath]))
-> [BufferPath] -> (Value, [ByteString], [BufferPath])
forall a b. (a -> b) -> a -> b
$ Widget -> [BufferPath]
forall a. IHaskellWidget a => a -> [BufferPath]
getBufferPaths Widget
widget
      Widget
-> Value -> (MessageHeader -> MessageHeader) -> IO KernelState
forall {p}.
IHaskellWidget p =>
p -> Value -> (MessageHeader -> MessageHeader) -> IO KernelState
sendMessageHdr Widget
widget (WidgetMethod -> Value
forall a. ToJSON a => a -> Value
toJSON (WidgetMethod -> Value) -> WidgetMethod -> Value
forall a b. (a -> b) -> a -> b
$ Value -> [BufferPath] -> WidgetMethod
UpdateState Value
newvalue [BufferPath]
bp) (\MessageHeader
h->MessageHeader
h {mhBuffers=buffers})

    Custom Widget
widget Value
value -> Widget -> Value -> IO KernelState
forall {p}. IHaskellWidget p => p -> Value -> IO KernelState
sendMessage Widget
widget (WidgetMethod -> Value
forall a. ToJSON a => a -> Value
toJSON (WidgetMethod -> Value) -> WidgetMethod -> Value
forall a b. (a -> b) -> a -> b
$ Value -> WidgetMethod
CustomContent Value
value)

    JSONValue Widget
widget Value
value -> Widget -> Value -> IO KernelState
forall {p}. IHaskellWidget p => p -> Value -> IO KernelState
sendMessage Widget
widget Value
value

    DispMsg Widget
widget Display
disp -> do
      MessageHeader
dispHeader <- MessageHeader -> MessageType -> IO MessageHeader
dupHeader MessageHeader
replyHeader MessageType
DisplayDataMessage
      let dmsg :: WidgetDisplay
dmsg = MessageHeader -> [DisplayData] -> WidgetDisplay
WidgetDisplay MessageHeader
dispHeader ([DisplayData] -> WidgetDisplay) -> [DisplayData] -> WidgetDisplay
forall a b. (a -> b) -> a -> b
$ Display -> [DisplayData]
unwrap Display
disp
      Widget -> Value -> IO KernelState
forall {p}. IHaskellWidget p => p -> Value -> IO KernelState
sendMessage Widget
widget (WidgetMethod -> Value
forall a. ToJSON a => a -> Value
toJSON (WidgetMethod -> Value) -> WidgetMethod -> Value
forall a b. (a -> b) -> a -> b
$ Value -> WidgetMethod
CustomContent (Value -> WidgetMethod) -> Value -> WidgetMethod
forall a b. (a -> b) -> a -> b
$ WidgetDisplay -> Value
forall a. ToJSON a => a -> Value
toJSON WidgetDisplay
dmsg)

    ClrOutput Bool
w -> do
      MessageHeader
hdr <- MessageHeader -> MessageType -> IO MessageHeader
dupHeader MessageHeader
replyHeader MessageType
ClearOutputMessage
      Message -> IO ()
send (Message -> IO ()) -> Message -> IO ()
forall a b. (a -> b) -> a -> b
$ MessageHeader -> Bool -> Message
ClearOutput MessageHeader
hdr Bool
w
      KernelState -> IO KernelState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return KernelState
state

  where
    oldComms :: Map UUID Widget
oldComms = KernelState -> Map UUID Widget
openComms KernelState
state
    sendMessage :: p -> Value -> IO KernelState
sendMessage p
widget Value
value = p -> Value -> (MessageHeader -> MessageHeader) -> IO KernelState
forall {p}.
IHaskellWidget p =>
p -> Value -> (MessageHeader -> MessageHeader) -> IO KernelState
sendMessageHdr p
widget Value
value MessageHeader -> MessageHeader
forall a. a -> a
id
    sendMessageHdr :: p -> Value -> (MessageHeader -> MessageHeader) -> IO KernelState
sendMessageHdr p
widget Value
value MessageHeader -> MessageHeader
hdrf = do
      let uuid :: UUID
uuid = p -> UUID
forall a. IHaskellWidget a => a -> UUID
getCommUUID p
widget
          present :: Bool
present = Maybe Widget -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Widget -> Bool) -> Maybe Widget -> Bool
forall a b. (a -> b) -> a -> b
$ UUID -> Map UUID Widget -> Maybe Widget
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UUID
uuid Map UUID Widget
oldComms

      -- If the widget is present, we send an update message on its comm.
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
present (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        MessageHeader
hdr <- MessageHeader -> MessageHeader
hdrf (MessageHeader -> MessageHeader)
-> IO MessageHeader -> IO MessageHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MessageHeader -> MessageType -> IO MessageHeader
dupHeader MessageHeader
replyHeader MessageType
CommDataMessage
        Message -> IO ()
send (Message -> IO ()) -> Message -> IO ()
forall a b. (a -> b) -> a -> b
$ MessageHeader -> UUID -> Value -> Message
CommData MessageHeader
hdr UUID
uuid Value
value
      KernelState -> IO KernelState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return KernelState
state

    unwrap :: Display -> [DisplayData]
    unwrap :: Display -> [DisplayData]
unwrap (ManyDisplay [Display]
ds) = (Display -> [DisplayData]) -> [Display] -> [DisplayData]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Display -> [DisplayData]
unwrap [Display]
ds
    unwrap (Display [DisplayData]
ddatas) = [DisplayData]
ddatas

    -- Removes the values that are buffers and puts them in the third value of the tuple
    -- The returned bufferpaths are the bufferpaths used
    processBPs :: Value -> [BufferPath] -> (Value, [ByteString], [BufferPath])
    -- Searching if the BufferPath key is in the Object is O(log n) or O(1) depending on implementation
    -- For this reason we fold on the bufferpaths
    processBPs :: Value -> [BufferPath] -> (Value, [ByteString], [BufferPath])
processBPs Value
val = ((Value, [ByteString], [BufferPath])
 -> BufferPath -> (Value, [ByteString], [BufferPath]))
-> (Value, [ByteString], [BufferPath])
-> [BufferPath]
-> (Value, [ByteString], [BufferPath])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Value, [ByteString], [BufferPath])
-> BufferPath -> (Value, [ByteString], [BufferPath])
f (Value
val,[],[])
      where
#if MIN_VERSION_aeson(2,0,0)
        nestedLookupRemove :: BufferPath -> Value -> (Value, Maybe Value)
        nestedLookupRemove :: BufferPath -> Value -> (Value, Maybe Value)
nestedLookupRemove [] Value
v = (Value
v, Maybe Value
forall a. Maybe a
Nothing)
        nestedLookupRemove (Text
k:BufferPath
ks) (Object Object
obj) =
          case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
key Object
obj of
               Just Value
subObj ->
                 if BufferPath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null BufferPath
ks
                 then (Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KM.delete Key
key Object
obj, Value -> Maybe Value
forall a. a -> Maybe a
Just Value
subObj)
                 else let (Value
newSubObj, Maybe Value
removed) = BufferPath -> Value -> (Value, Maybe Value)
nestedLookupRemove BufferPath
ks Value
subObj
                      in (Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert Key
key Value
newSubObj Object
obj, Maybe Value
removed)
               Maybe Value
Nothing -> (Object -> Value
Object Object
obj, Maybe Value
forall a. Maybe a
Nothing)
          where key :: Key
key = Text -> Key
Key.fromText Text
k
        nestedLookupRemove BufferPath
_ Value
v = (Value
v, Maybe Value
forall a. Maybe a
Nothing)
#else
        nestedLookupRemove :: BufferPath -> Value -> (Value, Maybe Value)
        nestedLookupRemove [] v = (v, Nothing)
        nestedLookupRemove (k:ks) (Object obj) =
          case HM.lookup k obj of
            Just subObj ->
              if null ks
              then (Object $ HM.delete k obj, Just subObj)
              else let (newSubObj, removed) = nestedLookupRemove ks subObj
                   in (Object $ HM.insert k newSubObj obj, removed)
            Nothing -> (Object obj, Nothing)
        nestedLookupRemove _ v = (v, Nothing)
#endif

        f :: (Value, [ByteString], [BufferPath]) -> BufferPath -> (Value, [ByteString], [BufferPath])
        f :: (Value, [ByteString], [BufferPath])
-> BufferPath -> (Value, [ByteString], [BufferPath])
f r :: (Value, [ByteString], [BufferPath])
r@(Value
v,[ByteString]
bs,[BufferPath]
bps) BufferPath
bp =
          case BufferPath -> Value -> (Value, Maybe Value)
nestedLookupRemove BufferPath
bp Value
v of
            (Value
newv, Just (String Text
b)) -> (Value
newv, ByteString -> ByteString
B64.decodeLenient (Text -> ByteString
encodeUtf8 Text
b) ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
bs, BufferPath
bpBufferPath -> [BufferPath] -> [BufferPath]
forall a. a -> [a] -> [a]
:[BufferPath]
bps)
            (Value, Maybe Value)
_ -> (Value, [ByteString], [BufferPath])
r

-- Override toJSON for PublishDisplayData for sending Display messages through [method .= custom]
data WidgetDisplay = WidgetDisplay MessageHeader [DisplayData]

instance ToJSON WidgetDisplay where
  toJSON :: WidgetDisplay -> Value
toJSON (WidgetDisplay MessageHeader
replyHeader [DisplayData]
ddata) =
    let pbval :: Value
pbval = Message -> Value
forall a. ToJSON a => a -> Value
toJSON (Message -> Value) -> Message -> Value
forall a b. (a -> b) -> a -> b
$ MessageHeader -> [DisplayData] -> Maybe Transient -> Message
PublishDisplayData MessageHeader
replyHeader [DisplayData]
ddata Maybe Transient
forall a. Maybe a
Nothing
    in IPythonMessage -> Value
forall a. ToJSON a => a -> Value
toJSON (IPythonMessage -> Value) -> IPythonMessage -> Value
forall a b. (a -> b) -> a -> b
$ MessageHeader -> Value -> MessageType -> IPythonMessage
IPythonMessage MessageHeader
replyHeader Value
pbval MessageType
DisplayDataMessage

data IPythonMessage = IPythonMessage MessageHeader Value MessageType

instance ToJSON IPythonMessage where
  toJSON :: IPythonMessage -> Value
toJSON (IPythonMessage MessageHeader
replyHeader Value
val MessageType
mtype) =
    [Pair] -> Value
object
      [ Key
"header" Key -> MessageHeader -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= MessageHeader
replyHeader
      , Key
"parent_header" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String -> String
str String
""
      , Key
"metadata" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object []
      , Key
"content" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
val
      , Key
"msg_type" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value)
-> (MessageType -> String) -> MessageType -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageType -> String
showMessageType (MessageType -> Value) -> MessageType -> Value
forall a b. (a -> b) -> a -> b
$ MessageType
mtype)
      ]

str :: String -> String
str :: String -> String
str = String -> String
forall a. a -> a
id

-- Handle messages one-by-one, while updating state simultaneously
widgetHandler :: (Message -> IO ())
              -> MessageHeader
              -> KernelState
              -> [WidgetMsg]
              -> IO KernelState
widgetHandler :: (Message -> IO ())
-> MessageHeader -> KernelState -> [WidgetMsg] -> IO KernelState
widgetHandler Message -> IO ()
sender MessageHeader
hdr = (KernelState -> WidgetMsg -> IO KernelState)
-> KernelState -> [WidgetMsg] -> IO KernelState
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Message -> IO ())
-> MessageHeader -> KernelState -> WidgetMsg -> IO KernelState
handleMessage Message -> IO ()
sender MessageHeader
hdr)