ihaskell 0.6.4.0 → 0.6.4.1
raw patch · 9 files changed
+597/−240 lines, 9 files
Files
- Hspec.hs +2/−1
- ihaskell.cabal +3/−1
- main/Main.hs +50/−91
- src/IHaskell/Display.hs +1/−6
- src/IHaskell/Eval/Evaluate.hs +150/−118
- src/IHaskell/Eval/Util.hs +9/−0
- src/IHaskell/Eval/Widgets.hs +212/−0
- src/IHaskell/Publish.hs +82/−0
- src/IHaskell/Types.hs +88/−23
Hspec.hs view
@@ -70,10 +70,11 @@ FinalResult outs page [] -> do modifyIORef outputAccum (outs :) modifyIORef pagerAccum (page :)+ noWidgetHandling s _ = return s getTemporaryDirectory >>= setCurrentDirectory let state = defaultKernelState { getLintStatus = LintOff }- interpret libdir False $ Eval.evaluate state string publish+ interpret libdir False $ Eval.evaluate state string publish noWidgetHandling out <- readIORef outputAccum pagerOut <- readIORef pagerAccum return (reverse out, unlines . map extractPlain . reverse $ pagerOut)
ihaskell.cabal view
@@ -7,7 +7,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.6.4.0+version: 0.6.4.1 -- A short (one-line) description of the package. synopsis: A Haskell backend kernel for the IPython project.@@ -106,7 +106,9 @@ IHaskell.Eval.Parser IHaskell.Eval.Hoogle IHaskell.Eval.ParseShell+ IHaskell.Eval.Widgets IHaskell.Eval.Util+ IHaskell.Publish IHaskell.IPython IHaskell.IPython.Stdin IHaskell.Flags
main/Main.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, ScopedTypeVariables, QuasiQuotes #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-} -- | Description : Argument parsing and basic messaging loop, using Haskell -- Chans to communicate with the ZeroMQ sockets.@@ -30,9 +30,11 @@ import IHaskell.Eval.Evaluate import IHaskell.Display import IHaskell.Eval.Info+import IHaskell.Eval.Widgets (widgetHandler) import IHaskell.Flags import IHaskell.IPython import IHaskell.Types+import IHaskell.Publish import IHaskell.IPython.ZeroMQ import IHaskell.IPython.Types import qualified IHaskell.IPython.Message.UUID as UUID@@ -48,9 +50,6 @@ dotToSpace '.' = ' ' dotToSpace x = x -ihaskellCSS :: String-ihaskellCSS = [hereFile|html/custom.css|]- consoleBanner :: Text consoleBanner = "Welcome to IHaskell! Run `IHaskell --help` for more information.\n" <>@@ -124,11 +123,12 @@ -- 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@@ -145,12 +145,14 @@ -- We handle comm messages and normal ones separately. The normal ones are a standard -- request/response style, while comms can be anything, and don't necessarily require a response. if isCommMessage request- then liftIO $ do- oldState <- takeMVar state+ then do+ oldState <- liftIO $ takeMVar state let replier = writeChan (iopubChannel interface)- newState <- handleComm replier oldState request replyHeader- putMVar state newState- writeChan (shellReplyChannel interface) SendNothing+ widgetMessageHandler = widgetHandler replier replyHeader+ tempState <- handleComm replier oldState request replyHeader+ newState <- flushWidgetMessages tempState [] widgetMessageHandler+ liftIO $ putMVar state newState+ liftIO $ writeChan (shellReplyChannel interface) SendNothing else do -- Create the reply, possibly modifying kernel state. oldState <- liftIO $ takeMVar state@@ -171,13 +173,6 @@ initialKernelState :: IO (MVar KernelState) initialKernelState = newMVar defaultKernelState --- | Duplicate a message header, giving it a new UUID and message type.-dupHeader :: MessageHeader -> MessageType -> IO MessageHeader-dupHeader header messageType = do- uuid <- liftIO UUID.random-- return header { messageId = uuid, msgType = messageType }- -- | Create a new message header, given a parent message header. createReplyHeader :: MessageHeader -> Interpreter MessageHeader createReplyHeader parent = do@@ -239,80 +234,16 @@ displayed <- liftIO $ newMVar [] updateNeeded <- liftIO $ newMVar False pagerOutput <- liftIO $ newMVar []- let clearOutput = do- header <- dupHeader replyHeader ClearOutputMessage- send $ ClearOutput header True - sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts- sendOutput (Display outs) = do- header <- dupHeader replyHeader DisplayDataMessage- send $ PublishDisplayData header "haskell" $ map (convertSvgToHtml . prependCss) outs-- convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ E.encodeUtf8 svg- convertSvgToHtml x = x-- makeSvgImg :: Base64 -> String- makeSvgImg base64data = T.unpack $ "<img src=\"data:image/svg+xml;base64," <>- base64data <>- "\"/>"-- prependCss (DisplayData MimeHtml html) =- DisplayData MimeHtml $ mconcat ["<style>", T.pack ihaskellCSS, "</style>", 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 :: EvaluationResult -> IO ()- publish result = do- let final =- case result of- IntermediateResult{} -> False- FinalResult{} -> True- outs = outputs result-- -- If necessary, clear all previous output and redraw.- clear <- readMVar updateNeeded- when clear $ do- clearOutput- disps <- readMVar displayed- mapM_ sendOutput $ reverse disps-- -- Draw this message.- sendOutput outs-- -- If this is the final message, add it to the list of completed messages. If it isn't, make sure we- -- clear it later by marking update needed as true.- modifyMVar_ updateNeeded (const $ return $ not final)- 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) $- if usePager state- then modifyMVar_ pagerOutput (return . (++ pager))- else sendOutput $ Display pager- 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+ let widgetMessageHandler = widgetHandler send replyHeader+ publish = publishResult send replyHeader displayed updateNeeded pagerOutput (usePager state)+ updatedState <- evaluate state (T.unpack code) publish widgetMessageHandler -- Notify the frontend that we're done computing. idleHeader <- liftIO $ dupHeader replyHeader StatusMessage@@ -362,21 +293,49 @@ } return (state, reply) -handleComm :: (Message -> IO ()) -> KernelState -> Message -> MessageHeader -> IO KernelState-handleComm replier kernelState req replyHeader = do+-- | 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 []+ let widgets = openComms kernelState uuid = commUuid req dat = commData req communicate value = do head <- dupHeader replyHeader CommDataMessage- replier $ CommData head uuid value- case Map.lookup uuid widgets of- Nothing -> fail $ "no widget with uuid " ++ show uuid+ send $ CommData head uuid value+ toUsePager = usePager 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++ newState <- case Map.lookup uuid widgets of+ Nothing -> return kernelState Just (Widget widget) -> case msgType $ header req of CommDataMessage -> do- comm widget dat communicate+ disp <- run $ comm widget dat communicate+ pgrOut <- liftIO $ readMVar pagerOutput+ liftIO $ publish $ FinalResult disp (if toUsePager then pgrOut else []) [] return kernelState CommCloseMessage -> do- close widget dat+ disp <- run $ close widget dat+ pgrOut <- liftIO $ readMVar pagerOutput+ 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++ return newState
src/IHaskell/Display.hs view
@@ -68,6 +68,7 @@ import qualified Data.Text.Encoding as E import IHaskell.Types+import IHaskell.Eval.Util (unfoldM) import StringUtils (rstrip) type Base64 = Text@@ -153,12 +154,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.
src/IHaskell/Eval/Evaluate.hs view
@@ -8,11 +8,13 @@ module IHaskell.Eval.Evaluate ( interpret, evaluate,+ flushWidgetMessages, Interpreter, liftIO, typeCleaner, globalImports, formatType,+ capturedIO, ) where import IHaskellPrelude@@ -82,6 +84,7 @@ import IHaskell.Display import qualified IHaskell.Eval.Hoogle as Hoogle import IHaskell.Eval.Util+import IHaskell.Eval.Widgets import IHaskell.BrokenPackages import qualified IHaskell.IPython.Message.UUID as UUID import StringUtils (replace, split, strip, rstrip)@@ -133,6 +136,7 @@ , "import qualified System.Directory as IHaskellDirectory" , "import qualified IHaskell.Display" , "import qualified IHaskell.IPython.Stdin"+ , "import qualified IHaskell.Eval.Widgets" , "import qualified System.Posix.IO as IHaskellIO" , "import qualified System.IO as IHaskellSysIO" , "import qualified Language.Haskell.TH as IHaskellTH"@@ -164,7 +168,9 @@ -- Run the rest of the interpreter action-#if MIN_VERSION_ghc(7,10,0)+#if MIN_VERSION_ghc(7,10,2)+packageIdString' dflags pkg_key = fromMaybe "(unknown)" (packageKeyPackageIdString dflags pkg_key)+#elif MIN_VERSION_ghc(7,10,0) packageIdString' dflags = packageKeyPackageIdString dflags #else packageIdString' dflags = packageIdString@@ -223,7 +229,7 @@ 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 @@ -235,9 +241,13 @@ imports <- mapM parseImportDecl $ globalImports ++ displayImports setContext $ map IIDecl $ implicitPrelude : imports + -- Set -fcontext-stack to 100 (default in ghc-7.10). ghc-7.8 uses 20, which is too small.+ let contextStackFlag = printf "-fcontext-stack=%d" (100 :: Int)+ void $ setFlags [contextStackFlag]+ -- | 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@@ -253,7 +263,7 @@ , evalResult :: Display , evalState :: KernelState , evalPager :: String- , evalComms :: [CommInfo]+ , evalMsgs :: [WidgetMsg] } cleanString :: String -> String@@ -274,9 +284,10 @@ -- | Evaluate some IPython input code. evaluate :: KernelState -- ^ The kernel state. -> String -- ^ Haskell code or other interpreter commands.- -> (EvaluationResult -> IO ()) -- ^ Function used to publish data outputs.+ -> Publisher -- ^ 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 @@ -322,26 +333,44 @@ helpStr = evalPager evalOut -- Output things only if they are non-empty.- let empty = noResults result && null helpStr && null (evalComms evalOut)+ let empty = noResults result && null helpStr unless empty $- liftIO $ output $ FinalResult result [plain helpStr] (evalComms evalOut)+ liftIO $ output $ FinalResult result [plain helpStr] [] - -- Make sure to clear all comms we've started.- let newState = evalState evalOut { evalComms = [] }+ let tempMsgs = evalMsgs evalOut+ tempState = evalState evalOut { evalMsgs = [] } + -- Handle the widget messages+ newState <- flushWidgetMessages tempState tempMsgs widgetHandler+ case evalStatus evalOut of Success -> runUntilFailure newState rest Failure -> return newState storeItCommand execCount = Statement $ printf "let it%d = it" execCount - extractValue :: Typeable a => String -> Interpreter a- extractValue expr = do- compiled <- dynCompileExpr expr- case fromDynamic compiled of- Nothing -> error "Error casting types in Evaluate.hs"- Just result -> return result+-- | 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+ case fromDynamic compiled of+ Nothing -> error "Error casting types in Evaluate.hs"+ Just result -> return result +flushWidgetMessages :: KernelState+ -> [WidgetMsg]+ -> (KernelState -> [WidgetMsg] -> IO KernelState)+ -> Interpreter KernelState+flushWidgetMessages state evalMsgs widgetHandler = do+ -- Capture all widget messages queued during code execution+ messagesIO <- extractValue "IHaskell.Eval.Widgets.relayWidgetMessages"+ messages <- liftIO messagesIO++ -- Handle all the widget messages+ let commMessages = evalMsgs ++ messages+ liftIO $ widgetHandler state commMessages+ safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut safely state = ghandle handler . ghandle sourceErrorHandler where@@ -353,7 +382,7 @@ , evalResult = displayError $ show exception , evalState = state , evalPager = ""- , evalComms = []+ , evalMsgs = [] } sourceErrorHandler :: SourceError -> Interpreter EvalOut@@ -372,7 +401,7 @@ , evalResult = displayError fullErr , evalState = state , evalPager = ""- , evalComms = []+ , evalMsgs = [] } wrapExecution :: KernelState@@ -386,7 +415,7 @@ , evalResult = res , evalState = state , evalPager = ""- , evalComms = []+ , evalMsgs = [] } -- | Return the display data for this command, as well as whether it resulted in an error.@@ -476,11 +505,11 @@ ] , evalState = state , evalPager = ""- , evalComms = []+ , evalMsgs = [] } 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@@ -502,7 +531,7 @@ , evalResult = display , evalState = state' , evalPager = ""- , evalComms = []+ , evalMsgs = [] } evalCommand output (Directive SetExtension opts) state = do@@ -536,7 +565,7 @@ , evalResult = displayError err , evalState = state , evalPager = ""- , evalComms = []+ , evalMsgs = [] } else let options = mapMaybe findOption $ words opts updater = foldl' (.) id $ map getUpdateKernelState options@@ -546,7 +575,7 @@ , evalResult = mempty , evalState = updater state , evalPager = ""- , evalComms = []+ , evalMsgs = [] } where@@ -680,7 +709,7 @@ , evalResult = Display [out] , evalState = state , evalPager = ""- , evalComms = []+ , evalMsgs = [] } where@@ -729,7 +758,7 @@ , evalResult = mempty , evalState = state , evalPager = output- , evalComms = []+ , evalMsgs = [] } evalCommand _ (Directive SearchHoogle query) state = safely state $ do@@ -740,44 +769,8 @@ results <- liftIO $ Hoogle.document query return $ hoogleResults state results -evalCommand output (Statement stmt) state = wrapExecution state $ do- write state $ "Statement:\n" ++ stmt- let outputter str = output $ IntermediateResult $ Display [plain str]- (printed, result) <- capturedStatement outputter stmt- case result of- RunOk names -> do- dflags <- getSessionDynFlags-- let allNames = map (showPpr dflags) names- isItName name =- name == "it" ||- name == "it" ++ show (getExecutionCounter state)- nonItNames = filter (not . isItName) allNames- output = [plain printed | not . null $ strip printed]-- write state $ "Names: " ++ show allNames-- -- Display the types of all bound names if the option is on. This is similar to GHCi :set +t.- if not $ useShowTypes state- then return $ Display output- else do- -- Get all the type strings.- types <- forM nonItNames $ \name -> do- theType <- showSDocUnqual dflags . ppr <$> exprType name- return $ name ++ " :: " ++ theType-- let joined = unlines types- htmled = unlines $ map formatGetType types-- return $- case extractPlain output of- "" -> Display [html htmled]-- -- Return plain and html versions. Previously there was only a plain version.- text -> Display [plain $ joined ++ "\n" ++ text, html $ htmled ++ mono text]-- RunException exception -> throw exception- RunBreak{} -> error "Should not break."+evalCommand output (Statement stmt) state = wrapExecution state $ evalStatementOrIO output state+ (CapturedStmt stmt) evalCommand output (Expression expr) state = do write state $ "Expression:\n" ++ expr@@ -806,7 +799,7 @@ -- 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@@ -814,31 +807,25 @@ , evalResult = mempty , evalState = state , evalPager = ""- , evalComms = []+ , evalMsgs = [] }- else do- if canRunDisplay- then 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- else return out- 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@@ -897,28 +884,6 @@ then display :: Display else removeSvg display - registerWidget :: EvalOut -> Ghc EvalOut- registerWidget 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'- }- isIO expr = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr postprocessShowError :: EvalOut -> EvalOut@@ -987,7 +952,7 @@ , evalResult = displayError $ formatParseError loc err , evalState = state , evalPager = ""- , evalComms = []+ , evalMsgs = [] } evalCommand _ (Pragma (PragmaUnsupported pragmaType) pragmas) state = wrapExecution state $@@ -1004,7 +969,7 @@ , evalResult = mempty , evalState = state , evalPager = output- , evalComms = []+ , evalMsgs = [] } where -- TODO: Make pager work with plaintext@@ -1031,7 +996,7 @@ 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.@@ -1093,10 +1058,13 @@ goStmt $ printf "let it = %s" itVariable act -capturedStatement :: (String -> IO ()) -- ^ Function used to publish intermediate output.- -> String -- ^ Statement to evaluate.- -> Interpreter (String, RunResult) -- ^ Return the output and result.-capturedStatement output stmt = do+data Captured a = CapturedStmt String+ | CapturedIO (IO a)++capturedEval :: (String -> IO ()) -- ^ Function used to publish intermediate output.+ -> 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 -- using the right names in the terminal. gen <- liftIO getStdGen@@ -1140,6 +1108,14 @@ goStmt :: String -> Ghc RunResult goStmt s = runStmt s RunToCompletion + runWithResult (CapturedStmt str) = goStmt str+ runWithResult (CapturedIO io) = do+ status <- gcatch (liftIO io >> return NoException) (return . AnyException)+ return $+ case status of+ NoException -> RunOk []+ AnyException e -> RunException e+ -- Initialize evaluation context. void $ forM initStmts goStmt @@ -1155,7 +1131,6 @@ fd <- head <$> unsafeCoerce hValues fdToHandle fd - -- Keep track of whether execution has completed. completed <- liftIO $ newMVar False finishedReading <- liftIO newEmptyMVar@@ -1198,7 +1173,7 @@ liftIO $ forkIO loop - result <- gfinally (goStmt stmt) $ do+ result <- gfinally (runWithResult stmt) $ do -- Execution is done. liftIO $ modifyMVar_ completed (const $ return True) @@ -1211,6 +1186,63 @@ printedOutput <- liftIO $ readMVar outputAccum return (printedOutput, result)++data AnyException = NoException+ | AnyException SomeException++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 (CapturedIO action)) handler++-- | 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]++ 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++ let allNames = map (showPpr dflags) names+ isItName name =+ name == "it" ||+ name == "it" ++ show (getExecutionCounter state)+ nonItNames = filter (not . isItName) allNames+ output = [plain printed | not . null $ strip printed]++ write state $ "Names: " ++ show allNames++ -- Display the types of all bound names if the option is on. This is similar to GHCi :set +t.+ if not $ useShowTypes state+ then return $ Display output+ else do+ -- Get all the type strings.+ types <- forM nonItNames $ \name -> do+ theType <- showSDocUnqual dflags . ppr <$> exprType name+ return $ name ++ " :: " ++ theType++ let joined = unlines types+ htmled = unlines $ map formatGetType types++ return $+ case extractPlain output of+ "" -> Display [html htmled]++ -- Return plain and html versions. Previously there was only a plain version.+ text -> Display [plain $ joined ++ "\n" ++ text, html $ htmled ++ mono text]++ RunException exception -> throw exception+ RunBreak{} -> error "Should not break." -- Read from a file handle until we hit a delimiter or until we've read as many characters as -- requested
src/IHaskell/Eval/Util.hs view
@@ -21,6 +21,9 @@ doc, pprDynFlags, pprLanguages,++ -- * Monad-loops+ unfoldM, ) where import IHaskellPrelude@@ -337,6 +340,12 @@ flags <- getSessionDynFlags let typeStr = O.showSDocUnqual flags $ O.ppr result return typeStr++-- | 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 -- | A wrapper around @getInfo@. Return info about each name in the string. getDescription :: GhcMonad m => String -> m [String]
+ src/IHaskell/Eval/Widgets.hs view
@@ -0,0 +1,212 @@+module IHaskell.Eval.Widgets (+ widgetSendOpen,+ widgetSendView,+ widgetSendUpdate,+ widgetSendCustom,+ widgetSendClose,+ widgetSendValue,+ widgetPublishDisplay,+ widgetClearOutput,+ relayWidgetMessages,+ widgetHandler,+ ) where++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)++import IHaskell.Display+import IHaskell.Eval.Util (unfoldM)+import IHaskell.IPython.Types (showMessageType)+import IHaskell.IPython.Message.UUID+import IHaskell.IPython.Message.Writer+import IHaskell.Types++-- 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++-- | Send a message to open a comm+widgetSendOpen :: IHaskellWidget a => a -> Value -> Value -> IO ()+widgetSendOpen widget initVal stateVal =+ queue $ Open (Widget widget) initVal stateVal++-- | Send a state update message+widgetSendUpdate :: IHaskellWidget a => a -> Value -> IO ()+widgetSendUpdate = widgetSend Update++-- | Send a [method .= display] comm_msg+widgetSendView :: IHaskellWidget a => a -> IO ()+widgetSendView = queue . View . Widget++-- | Send a comm_close+widgetSendClose :: IHaskellWidget a => a -> Value -> IO ()+widgetSendClose = widgetSend Close++-- | Send a [method .= custom, content .= value] comm_msg+widgetSendCustom :: IHaskellWidget a => a -> Value -> IO ()+widgetSendCustom = widgetSend Custom++-- | Send a custom Value+widgetSendValue :: IHaskellWidget a => a -> Value -> IO ()+widgetSendValue widget = queue . JSONValue (Widget widget)++-- | Send a `display_data` message as a [method .= custom] message+widgetPublishDisplay :: (IHaskellWidget a, IHaskellDisplay b) => a -> b -> IO ()+widgetPublishDisplay widget disp = display disp >>= queue . DispMsg (Widget widget)++-- | Send a `clear_output` message as a [method .= custom] message+widgetClearOutput :: IHaskellWidget a => a -> Bool -> IO ()+widgetClearOutput widget wait = queue $ ClrOutput (Widget widget) wait++-- | 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 send replyHeader state msg = do+ case msg of+ Open widget initVal stateVal -> do+ let target = targetName widget+ uuid = getCommUUID widget+ present = isJust $ Map.lookup uuid oldComms++ newComms = Map.insert uuid widget oldComms+ newState = state { openComms = newComms }++ communicate val = 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+ -- Send the comm open+ header <- dupHeader replyHeader CommOpenMessage+ send $ CommOpen header target uuid initVal++ -- Initial state update+ communicate . toJSON $ UpdateState stateVal++ -- Send anything else the widget requires.+ open widget communicate++ -- Store the widget in the kernelState+ return newState++ Close widget value -> do+ let target = targetName widget+ uuid = getCommUUID widget+ present = isJust $ Map.lookup uuid oldComms++ 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+ send $ CommClose header uuid value+ return newState+ else return state++ View widget -> sendMessage widget (toJSON DisplayWidget)++ Update widget value -> sendMessage widget (toJSON $ UpdateState value)++ Custom widget value -> sendMessage widget (toJSON $ CustomContent value)++ JSONValue widget value -> sendMessage widget value++ DispMsg widget disp -> do+ dispHeader <- dupHeader replyHeader DisplayDataMessage+ let dmsg = WidgetDisplay dispHeader "haskell" $ unwrap disp+ sendMessage widget (toJSON $ CustomContent $ toJSON dmsg)++ ClrOutput widget wait -> do+ header <- dupHeader replyHeader ClearOutputMessage+ let cmsg = WidgetClear header wait+ sendMessage widget (toJSON $ CustomContent $ toJSON cmsg)++ where+ oldComms = openComms state+ sendMessage widget value = do+ let uuid = getCommUUID widget+ present = isJust $ Map.lookup uuid oldComms++ -- If the widget is present, we send an update message on its comm.+ when present $ do+ header <- dupHeader replyHeader CommDataMessage+ send $ CommData header uuid value+ return state++ unwrap :: Display -> [DisplayData]+ unwrap (ManyDisplay ds) = concatMap unwrap ds+ unwrap (Display ddatas) = ddatas++-- Override toJSON for PublishDisplayData for sending Display messages through [method .= custom]+data WidgetDisplay = WidgetDisplay MessageHeader String [DisplayData]++instance ToJSON WidgetDisplay where+ toJSON (WidgetDisplay replyHeader source ddata) =+ let pbval = toJSON $ PublishDisplayData replyHeader source ddata+ in toJSON $ IPythonMessage replyHeader pbval DisplayDataMessage++-- Override toJSON for ClearOutput+data WidgetClear = WidgetClear MessageHeader Bool++instance ToJSON WidgetClear where+ toJSON (WidgetClear replyHeader wait) =+ let clrVal = toJSON $ ClearOutput replyHeader wait+ in toJSON $ IPythonMessage replyHeader clrVal ClearOutputMessage++data IPythonMessage = IPythonMessage MessageHeader Value MessageType++instance ToJSON IPythonMessage where+ toJSON (IPythonMessage replyHeader val msgType) =+ object+ [ "header" .= replyHeader+ , "parent_header" .= str ""+ , "metadata" .= str "{}"+ , "content" .= val+ , "msg_type" .= (toJSON . showMessageType $ msgType)+ ]++str :: String -> String+str = id++-- Handle messages one-by-one, while updating state simultaneously+widgetHandler :: (Message -> IO ())+ -> MessageHeader+ -> KernelState+ -> [WidgetMsg]+ -> IO KernelState+widgetHandler sender header = foldM (handleMessage sender header)
+ src/IHaskell/Publish.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE QuasiQuotes #-}++module IHaskell.Publish (publishResult) where++import IHaskellPrelude++import Data.String.Here (hereFile)+import qualified Data.Text as T+import qualified Data.Text.Encoding as E++import IHaskell.Display+import IHaskell.Types++ihaskellCSS :: String+ihaskellCSS = [hereFile|html/custom.css|]++-- | 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 =+ case result of+ IntermediateResult{} -> False+ FinalResult{} -> True+ outs = outputs result++ -- If necessary, clear all previous output and redraw.+ clear <- readMVar updateNeeded+ when clear $ do+ clearOutput+ disps <- readMVar displayed+ mapM_ sendOutput $ reverse disps++ -- Draw this message.+ sendOutput outs++ -- If this is the final message, add it to the list of completed messages. If it isn't, make sure we+ -- clear it later by marking update needed as true.+ modifyMVar_ updateNeeded (const $ return $ not final)+ when final $ do+ modifyMVar_ displayed (return . (outs :))++ -- If this has some pager output, store it for later.+ let pager = pagerOut result+ unless (null pager) $+ if usePager+ then modifyMVar_ pagerOutput (return . (++ pager))+ else sendOutput $ Display pager++ where+ clearOutput = do+ header <- dupHeader replyHeader ClearOutputMessage+ send $ ClearOutput header True++ sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts+ sendOutput (Display outs) = do+ header <- dupHeader replyHeader DisplayDataMessage+ send $ PublishDisplayData header "haskell" $ map (convertSvgToHtml . prependCss) outs++ convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ E.encodeUtf8 svg+ convertSvgToHtml x = x++ makeSvgImg :: Base64 -> String+ makeSvgImg base64data = T.unpack $ "<img src=\"data:image/svg+xml;base64," <>+ base64data <>+ "\"/>"++ prependCss (DisplayData MimeHtml html) =+ DisplayData MimeHtml $ mconcat ["<style>", T.pack ihaskellCSS, "</style>", html]+ prependCss x = x
src/IHaskell/Types.hs view
@@ -1,10 +1,15 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric, ExistentialQuantification #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} -- | Description : All message type definitions. module IHaskell.Types ( Message(..), MessageHeader(..), MessageType(..),+ dupHeader, Username, Metadata(..), replyType,@@ -26,21 +31,25 @@ 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.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 @@ -48,7 +57,7 @@ -- -- 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 +65,32 @@ -- | 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" + -- | 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 ()) -- ^ Way to respond to the message.+ 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 () @@ -86,6 +102,7 @@ instance IHaskellWidget Widget where 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@@ -93,6 +110,9 @@ instance Show Widget where show _ = "<Widget>" +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]@@ -112,7 +132,7 @@ data KernelState = KernelState { getExecutionCounter :: Int- , getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it. + , getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it. , useSvg :: Bool , useShowErrors :: Bool , useShowTypes :: Bool@@ -137,8 +157,8 @@ -- | 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`+ { 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. }@@ -162,21 +182,66 @@ | LintOff deriving (Eq, Show) -data CommInfo = CommInfo Widget UUID String- deriving Show+-- | Send JSON objects with specific formats+data WidgetMsg = Open Widget Value Value+ |+ -- ^ Cause the interpreter to open a new comm, and register the associated widget in+ -- the kernelState. Also sends a Value with comm_open, and then sends an initial+ -- state update Value.+ 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.+ Custom Widget Value+ |+ -- ^ A [method .= custom, content = value] message+ JSONValue Widget Value+ |+ -- ^ A json object that is sent to the widget without modifications.+ DispMsg Widget Display+ |+ -- ^ A 'display_data' message, sent as a [method .= custom] comm_msg+ ClrOutput Widget Bool+ -- ^ A 'clear_output' message, sent as a [method .= custom] comm_msg+ deriving (Show, Typeable) +data WidgetMethod = UpdateState Value+ | CustomContent Value+ | DisplayWidget++instance ToJSON WidgetMethod where+ toJSON DisplayWidget = object ["method" .= "display"]+ toJSON (UpdateState v) = object ["method" .= "update", "state" .= v]+ toJSON (CustomContent v) = object ["method" .= "custom", "content" .= v]+ -- | Output of evaluation. data EvaluationResult = -- | 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.+ { outputs :: Display -- ^ Display outputs. , pagerOut :: [DisplayData] -- ^ Mimebundles to display in the IPython -- pager.- , startComms :: [CommInfo] -- ^ Comms to start.+ , commMsgs :: [WidgetMsg] -- ^ Comm operations } deriving Show++-- | Duplicate a message header, giving it a new UUID and message type.+dupHeader :: MessageHeader -> MessageType -> IO MessageHeader+dupHeader header messageType = do+ uuid <- liftIO random++ return header { messageId = uuid, msgType = messageType }