diff --git a/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Button.hs b/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Button.hs index 99d5e7c4..a04e9ade 100644 --- a/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Button.hs +++ b/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Button.hs @@ -71,15 +71,16 @@ mkButton = do ttip <- newIORef "" dis <- newIORef False sty <- newIORef None - fun <- newIORef (\_ -> return ()) + fun <- newIORef $ const $ return () - let b = Button { uuid = commUUID - , description = desc - , tooltip = ttip - , disabled = dis - , buttonStyle = sty - , clickHandler = fun - } + let b = Button + { uuid = commUUID + , description = desc + , tooltip = ttip + , disabled = dis + , buttonStyle = sty + , clickHandler = fun + } -- Open a comm for this widget, and store it in the kernel state widgetSendOpen b (toJSON ButtonInitData) (toJSON b) @@ -87,9 +88,8 @@ mkButton = do -- Return the button widget return b --- | Send an update msg for a button, with custom json. Make it easy --- to update fragments of the state, by accepting a Pair instead of a --- Value. +-- | Send an update msg for a button, with custom json. Make it easy to update fragments of the +-- state, by accepting a Pair instead of a Value. update :: Button -> [Pair] -> IO () update b v = widgetSendUpdate b . toJSON . object $ v @@ -125,7 +125,7 @@ setButtonStatus b stat = do -- | Toggle the button toggleButtonStatus :: Button -> IO () toggleButtonStatus b = do - oldVal <- isDisabled b + oldVal <- getButtonStatus b let newVal = not oldVal modify b disabled newVal update b ["disabled" .= newVal] @@ -144,7 +144,7 @@ getButtonTooltip = readIORef . tooltip -- | Check whether the button is enabled / disabled getButtonStatus :: Button -> IO Bool -getButtonStatus = not . readIORef . disabled +getButtonStatus = fmap not . readIORef . disabled -- | Set a function to be activated on click setClickHandler :: Button -> (Button -> IO ()) -> IO () diff --git a/main/Main.hs b/main/Main.hs index 6df86c82..97016d99 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -293,8 +293,10 @@ replyTo _ HistoryRequest{} replyHeader state = do } return (state, reply) +-- | Handle comm messages handleComm :: (Message -> IO ()) -> KernelState -> Message -> MessageHeader -> Interpreter KernelState handleComm send kernelState req replyHeader = do + -- MVars to hold intermediate data during publishing displayed <- liftIO $ newMVar [] updateNeeded <- liftIO $ newMVar False pagerOutput <- liftIO $ newMVar [] @@ -306,8 +308,14 @@ handleComm send kernelState req replyHeader = do head <- dupHeader replyHeader CommDataMessage send $ CommData head uuid value toUsePager = usePager kernelState - run = capturedIO publish kernelState + + -- Create a publisher according to current state, use that to build + -- a function that executes an IO action and publishes the output to + -- the frontend simultaneously. + let run = capturedIO publish kernelState publish = publishResult send replyHeader displayed updateNeeded pagerOutput toUsePager + + -- Notify the frontend that the kernel is busy busyHeader <- liftIO $ dupHeader replyHeader StatusMessage liftIO . send $ PublishStatus busyHeader Busy @@ -326,6 +334,7 @@ handleComm send kernelState req replyHeader = do liftIO $ publish $ FinalResult disp (if toUsePager then pgrOut else []) [] return kernelState { openComms = Map.delete uuid widgets } + -- Notify the frontend that the kernel is idle once again idleHeader <- liftIO $ dupHeader replyHeader StatusMessage liftIO . send $ PublishStatus idleHeader Idle diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs index 57b7a6ea..79045c8f 100644 --- a/src/IHaskell/Eval/Evaluate.hs +++ b/src/IHaskell/Eval/Evaluate.hs @@ -87,7 +87,6 @@ import IHaskell.Eval.Util import IHaskell.Eval.Widgets 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) @@ -228,7 +227,7 @@ initializeImports = do dropFirstAndLast = reverse . drop 1 . reverse . drop 1 toImportStmt :: String -> String - toImportStmt = printf importFmt . concat . map capitalize . dropFirstAndLast . split "-" + toImportStmt = printf importFmt . concatMap capitalize . dropFirstAndLast . split "-" displayImports = map toImportStmt displayPackages @@ -242,7 +241,7 @@ initializeImports = do -- | Give a value for the `it` variable. initializeItVariable :: Interpreter () -initializeItVariable = do +initializeItVariable = -- This is required due to the way we handle `it` in the wrapper statements - if it doesn't exist, -- the first statement will fail. void $ runStmt "let it = ()" RunToCompletion @@ -344,6 +343,8 @@ evaluate kernelState code output widgetHandler = do storeItCommand execCount = Statement $ printf "let it%d = it" execCount +-- | Compile a string and extract a value from it. Effectively extract the result of an expression +-- from inside the notebook environment. extractValue :: Typeable a => String -> Interpreter a extractValue expr = do compiled <- dynCompileExpr expr @@ -502,7 +503,7 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do } else do -- Apply all IHaskell flag updaters to the state to get the new state - let state' = (foldl' (.) id (map (fromJust . ihaskellFlagUpdater) ihaskellFlags)) state + let state' = foldl' (.) id (map (fromJust . ihaskellFlagUpdater) ihaskellFlags) state errs <- setFlags ghcFlags let display = case errs of @@ -763,7 +764,7 @@ evalCommand _ (Directive GetDoc query) state = safely state $ do return $ hoogleResults state results evalCommand output (Statement stmt) state = wrapExecution state $ evalStatementOrIO output state - (Left stmt) + (CapturedStmt stmt) evalCommand output (Expression expr) state = do write state $ "Expression:\n" ++ expr @@ -792,7 +793,7 @@ evalCommand output (Expression expr) state = do -- If it typechecks as a DecsQ, we do not want to display the DecsQ, we just want the -- declaration made. do - write state $ "Suppressing display for template haskell declaration" + write state "Suppressing display for template haskell declaration" GHC.runDecls expr return EvalOut @@ -802,24 +803,23 @@ evalCommand output (Expression expr) state = do , evalPager = "" , evalMsgs = [] } - else do - if canRunDisplay - then do - -- Use the display. As a result, `it` is set to the output. - useDisplay displayExpr - else do - -- Evaluate this expression as though it's just a statement. The output is bound to 'it', so we can - -- then use it. - evalOut <- evalCommand output (Statement expr) state + else if canRunDisplay + then + -- Use the display. As a result, `it` is set to the output. + useDisplay displayExpr + else do + -- Evaluate this expression as though it's just a statement. The output is bound to 'it', so we can + -- then use it. + evalOut <- evalCommand output (Statement expr) state - let out = evalResult evalOut - showErr = isShowError out + let out = evalResult evalOut + showErr = isShowError out - -- If evaluation failed, return the failure. If it was successful, we may be able to use the - -- IHaskellDisplay typeclass. - return $ if not showErr || useShowErrors state - then evalOut - else postprocessShowError evalOut + -- If evaluation failed, return the failure. If it was successful, we may be able to use the + -- IHaskellDisplay typeclass. + return $ if not showErr || useShowErrors state + then evalOut + else postprocessShowError evalOut where -- Try to evaluate an action. Return True if it succeeds and False if it throws an exception. The @@ -990,7 +990,7 @@ doLoadModule name modName = do oldTargets <- getTargets -- Add a target, but make sure targets are unique! addTarget target - getTargets >>= return . (nubBy ((==) `on` targetId)) >>= setTargets + getTargets >>= return . nubBy ((==) `on` targetId) >>= setTargets result <- load LoadAllTargets -- Reset the context, since loading things screws it up. @@ -1052,8 +1052,11 @@ keepingItVariable act = do goStmt $ printf "let it = %s" itVariable act +data Captured a = CapturedStmt String + | CapturedIO (IO a) + capturedEval :: (String -> IO ()) -- ^ Function used to publish intermediate output. - -> Either String (IO a) -- ^ Statement to evaluate. + -> Captured a -- ^ Statement to evaluate. -> Interpreter (String, RunResult) -- ^ Return the output and result. capturedEval output stmt = do -- Generate random variable names to use so that we cannot accidentally override the variables by @@ -1099,8 +1102,8 @@ capturedEval output stmt = do goStmt :: String -> Ghc RunResult goStmt s = runStmt s RunToCompletion - runWithResult (Left str) = goStmt str - runWithResult (Right io) = do + runWithResult (CapturedStmt str) = goStmt str + runWithResult (CapturedIO io) = do status <- gcatch (liftIO io >> return NoException) (return . AnyException) return $ case status of @@ -1185,20 +1188,21 @@ capturedIO :: Publisher -> KernelState -> IO a -> Interpreter Display capturedIO publish state action = do let showError = return . displayError . show handler e@SomeException{} = showError e - gcatch (evalStatementOrIO publish state (Right action)) handler + gcatch (evalStatementOrIO publish state (CapturedIO action)) handler -evalStatementOrIO :: Publisher -> KernelState -> Either String (IO a) -> Interpreter Display +-- | Evaluate a @Captured@, and then publish the final result to the frontend. Returns the final +-- Display. +evalStatementOrIO :: Publisher -> KernelState -> Captured a -> Interpreter Display evalStatementOrIO publish state cmd = do let output str = publish . IntermediateResult $ Display [plain str] - (printed, result) <- case cmd of - Left stmt -> do - write state $ "Statement:\n" ++ stmt - capturedEval output (Left stmt) - Right io -> do - write state $ "evalStatementOrIO in Action" - capturedEval output (Right io) + case cmd of + CapturedStmt stmt -> + write state $ "Statement:\n" ++ stmt + CapturedIO io -> + write state "Evaluating Action" + (printed, result) <- capturedEval output cmd case result of RunOk names -> do dflags <- getSessionDynFlags diff --git a/src/IHaskell/Eval/Widgets.hs b/src/IHaskell/Eval/Widgets.hs index 6f4b52b7..e0771082 100644 --- a/src/IHaskell/Eval/Widgets.hs +++ b/src/IHaskell/Eval/Widgets.hs @@ -12,6 +12,7 @@ import IHaskellPrelude import Control.Concurrent.Chan (writeChan) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan +import Control.Monad (foldM) import Data.Aeson import qualified Data.Map as Map import System.IO.Unsafe (unsafePerformIO) @@ -57,6 +58,8 @@ widgetSendView = queue . View . Widget widgetSendClose :: IHaskellWidget a => a -> Value -> IO () widgetSendClose = widgetSend Close +-- | 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 @@ -66,7 +69,7 @@ handleMessage send replyHeader state msg = do let oldComms = openComms state case msg of - (Open widget initVal stateVal) -> do + Open widget initVal stateVal -> do let target = targetName widget uuid = getCommUUID widget present = isJust $ Map.lookup uuid oldComms @@ -78,6 +81,7 @@ handleMessage send replyHeader state msg = do head <- dupHeader replyHeader CommDataMessage send $ CommData head uuid val + -- If the widget is present, don't open it again. if present then return state else do @@ -94,7 +98,7 @@ handleMessage send replyHeader state msg = do -- Store the widget in the kernelState return newState - (Close widget value) -> do + Close widget value -> do let target = targetName widget uuid = getCommUUID widget present = isJust $ Map.lookup uuid oldComms @@ -102,6 +106,7 @@ handleMessage send replyHeader state msg = do newComms = Map.delete uuid $ openComms state newState = state { openComms = newComms } + -- If the widget is not present in the state, we don't close it. if present then do header <- dupHeader replyHeader CommCloseMessage @@ -109,24 +114,28 @@ handleMessage send replyHeader state msg = do return newState else return state - (View widget) -> do + View widget -> do let uuid = getCommUUID widget present = isJust $ Map.lookup uuid oldComms + -- If the widget is present, we send a display message on it's comm. when present $ do header <- dupHeader replyHeader CommDataMessage send . CommData header uuid $ toJSON DisplayWidget return state - (Update widget value) -> do + Update widget value -> do -- 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. let uuid = getCommUUID widget present = isJust $ Map.lookup uuid oldComms + -- The update inside the kernel state happens here. newComms = Map.insert uuid widget oldComms newState = state { openComms = newComms } + -- If the widget is present, we send an update message on its comm. We also replace the widget + -- stored in the kernel state with the one provided here. if present then do header <- dupHeader replyHeader CommDataMessage @@ -134,12 +143,10 @@ handleMessage send replyHeader state msg = do return newState else return state +-- Handle messages one-by-one, while updating state simultaneously widgetHandler :: (Message -> IO ()) -> MessageHeader -> KernelState -> [WidgetMsg] -> IO KernelState -widgetHandler _ _ state [] = return state -widgetHandler sender header state (x:xs) = do - newState <- handleMessage sender header state x - widgetHandler sender header newState xs +widgetHandler sender header = foldM (handleMessage sender header) diff --git a/src/IHaskell/Publish.hs b/src/IHaskell/Publish.hs index 01a2baaf..5d91e9c5 100644 --- a/src/IHaskell/Publish.hs +++ b/src/IHaskell/Publish.hs @@ -14,14 +14,20 @@ import IHaskell.Types ihaskellCSS :: String ihaskellCSS = [hereFile|html/custom.css|] --- Publish outputs, ignore any CommMsgs -publishResult :: (Message -> IO ()) - -> MessageHeader - -> MVar [Display] - -> MVar Bool - -> MVar [DisplayData] - -> Bool - -> EvaluationResult +-- | Publish evaluation results, ignore any CommMsgs. This function can be used to create a function +-- of type (EvaluationResult -> IO ()), which can be used to publish results to the frontend. The +-- resultant function shares some state between different calls by storing it inside the MVars +-- passed while creating it using this function. Pager output is accumulated in the MVar passed for +-- this purpose if a pager is being used (indicated by an argument), and sent to the frontend +-- otherwise. +publishResult :: (Message -> IO ()) -- ^ A function to send messages + -> MessageHeader -- ^ Message header to use for reply + -> MVar [Display] -- ^ A MVar to use for displays + -> MVar Bool -- ^ A mutable boolean to decide whether the output need to be cleared and + -- redrawn + -> MVar [DisplayData] -- ^ A MVar to use for storing pager output + -> Bool -- ^ Whether to use the pager + -> EvaluationResult -- ^ The evaluation result -> IO () publishResult send replyHeader displayed updateNeeded pagerOutput usePager result = do let final = diff --git a/src/IHaskellPrelude.hs b/src/IHaskellPrelude.hs index 68cff3e5..4938a5a4 100644 --- a/src/IHaskellPrelude.hs +++ b/src/IHaskellPrelude.hs @@ -147,4 +147,3 @@ putChar = liftIO . P.putChar print :: (MonadIO m, Show a) => a -> m () print = liftIO . P.print -