diff --git a/ihaskell.cabal b/ihaskell.cabal index a98d5f04..6ce41f94 100644 --- a/ihaskell.cabal +++ b/ihaskell.cabal @@ -106,6 +106,7 @@ library IHaskell.Eval.Parser IHaskell.Eval.Hoogle IHaskell.Eval.ParseShell + IHaskell.Eval.Widgets IHaskell.Eval.Util IHaskell.IPython IHaskell.IPython.Stdin diff --git a/main/Main.hs b/main/Main.hs index 35eb31bc..479d2695 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -124,11 +124,12 @@ runKernel kernelOpts profileSrc = do -- Initialize the context by evaluating everything we got from the command line flags. let noPublish _ = return () + noWidget s _ = return s evaluator line = void $ do -- Create a new state each time. stateVar <- liftIO initialKernelState state <- liftIO $ takeMVar stateVar - evaluate state line noPublish + evaluate state line noPublish noWidget confFile <- liftIO $ kernelSpecConfFile kernelOpts case confFile of @@ -260,18 +261,7 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do DisplayData MimeHtml $ mconcat ["", html] prependCss x = x - startComm :: CommInfo -> IO () - startComm (CommInfo widget uuid target) = do - -- Send the actual comm open. - header <- dupHeader replyHeader CommOpenMessage - send $ CommOpen header target uuid (Object mempty) - - -- Send anything else the widget requires. - let communicate value = do - head <- dupHeader replyHeader CommDataMessage - writeChan (iopubChannel interface) $ CommData head uuid value - open widget communicate - + -- Publish outputs, ignore any CommMsgs publish :: EvaluationResult -> IO () publish result = do let final = @@ -296,9 +286,6 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do when final $ do modifyMVar_ displayed (return . (outs :)) - -- Start all comms that need to be started. - mapM_ startComm $ startComms result - -- If this has some pager output, store it for later. let pager = pagerOut result unless (null pager) $ @@ -306,13 +293,92 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do then modifyMVar_ pagerOutput (return . (++ pager)) else sendOutput $ Display pager + handleMessage :: KernelState -> WidgetMsg -> IO KernelState + handleMessage state (Open widget value) = do + -- Check whether the widget is already present in the state + let oldComms = openComms state + uuid = getCommUUID widget + present = isJust $ Map.lookup uuid oldComms + + newComms = Map.insert uuid widget $ openComms state + newState = state { openComms = newComms } + + target = targetName widget + + communicate value = do + head <- dupHeader replyHeader CommDataMessage + writeChan (iopubChannel interface) $ CommData head uuid value + + if present + then return state + else do -- Send the comm open + header <- dupHeader replyHeader CommOpenMessage + send $ CommOpen header target uuid value + + -- Send anything else the widget requires. + open widget communicate + + -- Store the widget in the kernelState + return newState + + handleMessage state (Close widget value) = do + let oldComms = openComms state + present = isJust $ Map.lookup (getCommUUID widget) oldComms + + target = targetName widget + uuid = getCommUUID widget + + newComms = Map.delete uuid $ openComms state + newState = state { openComms = newComms } + + if present + then do header <- dupHeader replyHeader CommCloseMessage + send $ CommClose header uuid value + return newState + else return state + + handleMessage state (View widget) = do + let oldComms = openComms state + uuid = getCommUUID widget + present = isJust $ Map.lookup (getCommUUID widget) oldComms + + when present $ do + header <- dupHeader replyHeader CommDataMessage + send . CommData header uuid $ toJSON DisplayWidget + + return state + + -- Assume that a state update means that it is time the stored widget also gets updated. + -- Thus replace the stored widget with the copy passed in the CommMsg. + handleMessage state (Update widget value) = do + let oldComms = openComms state + present = isJust $ Map.lookup (getCommUUID widget) oldComms + + target = targetName widget + uuid = getCommUUID widget + + newComms = Map.insert uuid widget $ openComms state + newState = state { openComms = newComms } + + if present + then do header <- dupHeader replyHeader CommDataMessage + send . CommData header uuid . toJSON $ UpdateState value + return newState + else return state + + widgetHandler :: KernelState -> [WidgetMsg] -> IO KernelState + widgetHandler state [] = return state + widgetHandler state (x:xs) = do + newState <- handleMessage state x + widgetHandler newState xs + let execCount = getExecutionCounter state -- Let all frontends know the execution count and code that's about to run inputHeader <- liftIO $ dupHeader replyHeader InputMessage send $ PublishInput inputHeader (T.unpack code) execCount -- Run code and publish to the frontend as we go. - updatedState <- evaluate state (T.unpack code) publish + updatedState <- evaluate state (T.unpack code) publish widgetHandler -- Notify the frontend that we're done computing. idleHeader <- liftIO $ dupHeader replyHeader StatusMessage diff --git a/src/IHaskell/Display.hs b/src/IHaskell/Display.hs index 47238ba4..66758fbc 100644 --- a/src/IHaskell/Display.hs +++ b/src/IHaskell/Display.hs @@ -68,6 +68,7 @@ import System.IO.Unsafe (unsafePerformIO) import qualified Data.Text.Encoding as E import IHaskell.Types +import IHaskell.Eval.Util (unfoldM) import StringUtils (rstrip) type Base64 = Text @@ -154,12 +155,6 @@ displayFromChan :: IO (Maybe Display) displayFromChan = Just . many <$> unfoldM (atomically $ tryReadTChan displayChan) --- | This is unfoldM from monad-loops. It repeatedly runs an IO action until it return Nothing, and --- puts all the Justs in a list. If you find yourself using more functionality from monad-loops, --- just add the package dependency instead of copying more code from it. -unfoldM :: IO (Maybe a) -> IO [a] -unfoldM f = maybe (return []) (\r -> (r :) <$> unfoldM f) =<< f - -- | Write to the display channel. The contents will be displayed in the notebook once the current -- execution call ends. printDisplay :: IHaskellDisplay a => a -> IO () diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs index f0317c09..6a1ac434 100644 --- a/src/IHaskell/Eval/Evaluate.hs +++ b/src/IHaskell/Eval/Evaluate.hs @@ -84,6 +84,7 @@ import qualified IHaskell.Eval.Hoogle as Hoogle import IHaskell.Eval.Util import IHaskell.BrokenPackages import qualified IHaskell.IPython.Message.UUID as UUID +import IHaskell.Eval.Widgets import StringUtils (replace, split, strip, rstrip) import Paths_ihaskell (version) @@ -251,9 +252,9 @@ data EvalOut = EvalOut { evalStatus :: ErrorOccurred , evalResult :: Display - , evalState :: KernelState - , evalPager :: String - , evalComms :: [CommInfo] + , evalState :: KernelState + , evalPager :: String + , evalMsgs :: [WidgetMsg] } cleanString :: String -> String @@ -275,8 +276,9 @@ cleanString x = if allBrackets evaluate :: KernelState -- ^ The kernel state. -> String -- ^ Haskell code or other interpreter commands. -> (EvaluationResult -> IO ()) -- ^ Function used to publish data outputs. + -> (KernelState -> [WidgetMsg] -> IO KernelState) -- ^ Function to handle widget messages -> Interpreter KernelState -evaluate kernelState code output = do +evaluate kernelState code output widgetHandler = do cmds <- parseString (cleanString code) let execCount = getExecutionCounter kernelState @@ -321,13 +323,18 @@ evaluate kernelState code output = do Just disps -> evalResult evalOut <> disps helpStr = evalPager evalOut - -- Output things only if they are non-empty. - let empty = noResults result && null helpStr && null (evalComms evalOut) - unless empty $ - liftIO $ output $ FinalResult result [plain helpStr] (evalComms evalOut) + -- Capture all widget messages queued during code execution + messagesIO <- extractValue "IHaskell.Eval.Widgets.relayWidgetMessages" + messages <- liftIO messagesIO + let commMessages = evalMsgs evalOut ++ messages - -- Make sure to clear all comms we've started. - let newState = evalState evalOut { evalComms = [] } + -- Output things only if they are non-empty. + let empty = noResults result && null helpStr + unless empty $ + liftIO $ output $ FinalResult result [plain helpStr] [] + + -- Handle all the widget messages + newState <- liftIO $ widgetHandler (evalState evalOut) commMessages case evalStatus evalOut of Success -> runUntilFailure newState rest @@ -353,7 +360,7 @@ safely state = ghandle handler . ghandle sourceErrorHandler , evalResult = displayError $ show exception , evalState = state , evalPager = "" - , evalComms = [] + , evalMsgs = [] } sourceErrorHandler :: SourceError -> Interpreter EvalOut @@ -372,7 +379,7 @@ safely state = ghandle handler . ghandle sourceErrorHandler , evalResult = displayError fullErr , evalState = state , evalPager = "" - , evalComms = [] + , evalMsgs = [] } wrapExecution :: KernelState @@ -386,7 +393,7 @@ wrapExecution state exec = safely state $ , evalResult = res , evalState = state , evalPager = "" - , evalComms = [] + , evalMsgs = [] } -- | Return the display data for this command, as well as whether it resulted in an error. @@ -476,7 +483,7 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do ] , evalState = state , evalPager = "" - , evalComms = [] + , evalMsgs = [] } else do -- Apply all IHaskell flag updaters to the state to get the new state @@ -502,7 +509,7 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do , evalResult = display , evalState = state' , evalPager = "" - , evalComms = [] + , evalMsgs = [] } evalCommand output (Directive SetExtension opts) state = do @@ -536,7 +543,7 @@ evalCommand a (Directive SetOption opts) state = do , evalResult = displayError err , evalState = state , evalPager = "" - , evalComms = [] + , evalMsgs = [] } else let options = mapMaybe findOption $ words opts updater = foldl' (.) id $ map getUpdateKernelState options @@ -546,7 +553,7 @@ evalCommand a (Directive SetOption opts) state = do , evalResult = mempty , evalState = updater state , evalPager = "" - , evalComms = [] + , evalMsgs = [] } where @@ -680,7 +687,7 @@ evalCommand _ (Directive GetHelp _) state = do , evalResult = Display [out] , evalState = state , evalPager = "" - , evalComms = [] + , evalMsgs = [] } where @@ -729,7 +736,7 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do , evalResult = mempty , evalState = state , evalPager = output - , evalComms = [] + , evalMsgs = [] } evalCommand _ (Directive SearchHoogle query) state = safely state $ do @@ -814,7 +821,7 @@ evalCommand output (Expression expr) state = do , evalResult = mempty , evalState = state , evalPager = "" - , evalComms = [] + , evalMsgs = [] } else do if canRunDisplay @@ -822,9 +829,8 @@ evalCommand output (Expression expr) state = do -- Use the display. As a result, `it` is set to the output. out <- useDisplay displayExpr - -- Register the `it` object as a widget. if isWidget - then registerWidget out + then displayWidget out else return out else do -- Evaluate this expression as though it's just a statement. The output is bound to 'it', so we can @@ -897,27 +903,22 @@ evalCommand output (Expression expr) state = do then display :: Display else removeSvg display - registerWidget :: EvalOut -> Ghc EvalOut - registerWidget evalOut = + displayWidget :: EvalOut -> Ghc EvalOut + displayWidget evalOut = case evalStatus evalOut of Failure -> return evalOut Success -> do element <- dynCompileExpr "IHaskell.Display.Widget it" case fromDynamic element of Nothing -> error "Expecting widget" - Just widget -> do - -- Stick the widget in the kernel state. - uuid <- liftIO UUID.random - let state = evalState evalOut - newComms = Map.insert uuid widget $ openComms state - state' = state { openComms = newComms } - - -- Store the fact that we should start this comm. - return - evalOut - { evalComms = CommInfo widget uuid (targetName widget) : evalComms evalOut - , evalState = state' - } + Just (Widget widget) -> do + let oldComms = openComms state + uuid = getCommUUID widget + case Map.lookup uuid oldComms of + Nothing -> error "Unregistered widget" + Just w -> do + liftIO $ widgetSendView widget + return evalOut isIO expr = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr @@ -987,7 +988,7 @@ evalCommand _ (ParseError loc err) state = do , evalResult = displayError $ formatParseError loc err , evalState = state , evalPager = "" - , evalComms = [] + , evalMsgs = [] } evalCommand _ (Pragma (PragmaUnsupported pragmaType) pragmas) state = wrapExecution state $ @@ -1004,7 +1005,7 @@ hoogleResults state results = , evalResult = mempty , evalState = state , evalPager = output - , evalComms = [] + , evalMsgs = [] } where -- TODO: Make pager work with plaintext diff --git a/src/IHaskell/Eval/Util.hs b/src/IHaskell/Eval/Util.hs index a25aaf50..3328eee9 100644 --- a/src/IHaskell/Eval/Util.hs +++ b/src/IHaskell/Eval/Util.hs @@ -21,6 +21,9 @@ module IHaskell.Eval.Util ( doc, pprDynFlags, pprLanguages, + + -- * Monad-loops + unfoldM, ) where import IHaskellPrelude @@ -385,3 +388,9 @@ getDescription str = do if fixity == GHC.defaultFixity then O.empty else O.ppr fixity O.<+> pprInfixName (getName thing) + +-- | This is unfoldM from monad-loops. It repeatedly runs an IO action until it return Nothing, and +-- puts all the Justs in a list. If you find yourself using more functionality from monad-loops, +-- just add the package dependency instead of copying more code from it. +unfoldM :: IO (Maybe a) -> IO [a] +unfoldM f = maybe (return []) (\r -> (r :) <$> unfoldM f) =<< f diff --git a/src/IHaskell/Eval/Widgets.hs b/src/IHaskell/Eval/Widgets.hs new file mode 100644 index 00000000..363dfb1d --- /dev/null +++ b/src/IHaskell/Eval/Widgets.hs @@ -0,0 +1,53 @@ +module IHaskell.Eval.Widgets + ( widgetSendOpen + , widgetSendUpdate + , widgetSendView + , widgetSendClose + ) where + +import IHaskellPrelude + +import Data.Aeson (Value) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TChan +import System.IO.Unsafe (unsafePerformIO) + +import IHaskell.Display +import IHaskell.Types (Message (..), WidgetMsg (..)) +import IHaskell.IPython.Message.UUID +import IHaskell.Eval.Util (unfoldM) + +-- All comm_open messages go here +widgetMessages :: TChan WidgetMsg +{-# NOINLINE widgetMessages #-} +widgetMessages = unsafePerformIO newTChanIO + +-- | Return all pending comm_close messages +relayWidgetMessages :: IO [WidgetMsg] +relayWidgetMessages = relayMessages widgetMessages + +-- | Extract all messages from a TChan and wrap them in a list +relayMessages :: TChan a -> IO [a] +relayMessages = unfoldM . atomically . tryReadTChan + +-- | Write a widget message to the chan +queue :: WidgetMsg -> IO () +queue = atomically . writeTChan widgetMessages + +-- | Send a message +widgetSend :: IHaskellWidget a + => (Widget -> Value -> WidgetMsg) + -> a -> Value -> IO () +widgetSend msgType widget value = queue $ msgType (Widget widget) value + +widgetSendOpen :: IHaskellWidget a => a -> Value -> IO () +widgetSendOpen = widgetSend Open + +widgetSendUpdate :: IHaskellWidget a => a -> Value -> IO () +widgetSendUpdate = widgetSend Update + +widgetSendView :: IHaskellWidget a => a -> IO () +widgetSendView = queue . View . Widget + +widgetSendClose :: IHaskellWidget a => a -> Value -> IO () +widgetSendClose = widgetSend Close diff --git a/src/IHaskell/Types.hs b/src/IHaskell/Types.hs index 63a1e208..00e2b0f3 100644 --- a/src/IHaskell/Types.hs +++ b/src/IHaskell/Types.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric, ExistentialQuantification #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} -- | Description : All message type definitions. module IHaskell.Types ( @@ -26,29 +30,33 @@ module IHaskell.Types ( IHaskellDisplay(..), IHaskellWidget(..), Widget(..), - CommInfo(..), + WidgetMsg(..), + WidgetMethod(..), KernelSpec(..), ) where import IHaskellPrelude -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Char8 as CBS -import qualified Data.ByteString.Char8 as Char +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as CBS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT + +import Data.Aeson (Value, (.=), object) +import Data.Aeson.Types (emptyObject) +import qualified Data.ByteString.Char8 as Char +import Data.Function (on) import Data.Serialize import GHC.Generics -import Data.Aeson (Value) import IHaskell.IPython.Kernel -- | A class for displayable Haskell types. -- --- IHaskell's displaying of results behaves as if these two overlapping/undecidable instances also --- existed: --- +-- IHaskell's displaying of results behaves as if these two +-- overlapping/undecidable instances also existed: +-- -- > instance (Show a) => IHaskellDisplay a -- > instance Show a where shows _ = id class IHaskellDisplay a where @@ -56,25 +64,34 @@ class IHaskellDisplay a where -- | Display as an interactive widget. class IHaskellDisplay a => IHaskellWidget a where - -- | Output target name for this widget. The actual input parameter should be ignored. + -- | Output target name for this widget. The actual input parameter + -- should be ignored. By default evaluate to "ipython.widget", which + -- is used by IPython for its backbone widgets. targetName :: a -> String + targetName _ = "ipython.widget" - -- | Called when the comm is opened. Allows additional messages to be sent after comm open. - open :: a -- ^ Widget to open a comm port with. - -> (Value -> IO ()) -- ^ Way to respond to the message. + -- | Get the uuid for comm associated with this widget. The widget + -- is responsible for storing the UUID during initialization. + getCommUUID :: a -> UUID + + -- | Called when the comm is opened. Allows additional messages to + -- be sent after comm open. + open :: a -- ^ Widget to open a comm port with. + -> (Value -> IO ()) -- ^ A function for sending messages. -> IO () open _ _ = return () - -- | Respond to a comm data message. - comm :: a -- ^ Widget which is being communicated with. - -> Value -- ^ Sent data. + -- | Respond to a comm data message. Called when a message is + -- recieved on the comm associated with the widget. + comm :: a -- ^ Widget which is being communicated with. + -> Value -- ^ Data recieved from the frontend. -> (Value -> IO ()) -- ^ Way to respond to the message. -> IO () comm _ _ _ = return () - -- | Close the comm, releasing any resources we might need to. + -- | Called when a comm_close is recieved from the frontend. close :: a -- ^ Widget to close comm port with. - -> Value -- ^ Sent data. + -> Value -- ^ Data recieved from the frontend. -> IO () close _ _ = return () @@ -85,16 +102,20 @@ instance IHaskellDisplay Widget where display (Widget widget) = display widget instance IHaskellWidget Widget where - targetName (Widget widget) = targetName widget - open (Widget widget) = open widget - comm (Widget widget) = comm widget - close (Widget widget) = close widget + targetName (Widget widget) = targetName widget + getCommUUID (Widget widget) = getCommUUID widget + open (Widget widget) = open widget + comm (Widget widget) = comm widget + close (Widget widget) = close widget instance Show Widget where show _ = "" --- | Wrapper for ipython-kernel's DisplayData which allows sending multiple results from the same --- expression. +instance Eq Widget where + (==) = (==) `on` getCommUUID + +-- | Wrapper for ipython-kernel's DisplayData which allows sending +-- multiple results from the same expression. data Display = Display [DisplayData] | ManyDisplay [Display] deriving (Show, Typeable, Generic) @@ -112,13 +133,13 @@ instance Monoid Display where data KernelState = KernelState { getExecutionCounter :: Int - , getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it. - , useSvg :: Bool - , useShowErrors :: Bool - , useShowTypes :: Bool - , usePager :: Bool - , openComms :: Map UUID Widget - , kernelDebug :: Bool + , getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it. + , useSvg :: Bool + , useShowErrors :: Bool + , useShowTypes :: Bool + , usePager :: Bool + , openComms :: Map UUID Widget + , kernelDebug :: Bool } deriving Show @@ -137,10 +158,9 @@ defaultKernelState = KernelState -- | Kernel options to be set via `:set` and `:option`. data KernelOpt = KernelOpt - { getOptionName :: [String] -- ^ Ways to set this option via `:option` - , getSetName :: [String] -- ^ Ways to set this option via `:set` - , getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel - -- state. + { getOptionName :: [String] -- ^ Ways to set this option via `:option` + , getSetName :: [String] -- ^ Ways to set this option via `:set` + , getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel state. } kernelOpts :: [KernelOpt] @@ -162,21 +182,42 @@ data LintStatus = LintOn | LintOff deriving (Eq, Show) -data CommInfo = CommInfo Widget UUID String +data WidgetMsg = Open Widget Value + -- ^ Cause the interpreter to open a new comm, and + -- register the associated widget in the + -- kernelState. + | Update Widget Value + -- ^ Cause the interpreter to send a comm_msg + -- containing a state update for the widget. + -- Can be used to send fragments of state for update. + -- Also updates the value of widget stored in the kernelState + | View Widget + -- ^ Cause the interpreter to send a comm_msg + -- containing a display command for the frontend. + | Close Widget Value + -- ^ Cause the interpreter to close the comm + -- associated with the widget. Also sends data with + -- comm_close. deriving Show +data WidgetMethod = UpdateState Value + | DisplayWidget + +instance ToJSON WidgetMethod where + toJSON DisplayWidget = object [ "method" .= "display" ] + toJSON (UpdateState v) = object [ "method" .= "update" + , "state" .= v ] + -- | Output of evaluation. data EvaluationResult = - -- | An intermediate result which communicates what has been printed thus - -- far. + -- | An intermediate result which communicates what has been printed thus far. IntermediateResult - { outputs :: Display -- ^ Display outputs. + { outputs :: Display -- ^ Display outputs. } | FinalResult - { outputs :: Display -- ^ Display outputs. - , pagerOut :: [DisplayData] -- ^ Mimebundles to display in the IPython - -- pager. - , startComms :: [CommInfo] -- ^ Comms to start. + { outputs :: Display -- ^ Display outputs. + , pagerOut :: [DisplayData] -- ^ Mimebundles to display in the IPython pager. + , commMsgs :: [WidgetMsg] -- ^ Comm operations } deriving Show