1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables #-}
-- | Description : Argument parsing and basic messaging loop, using Haskell
-- Chans to communicate with the ZeroMQ sockets.
module Main where
-- Prelude imports.
import ClassyPrelude hiding (last, liftIO)
import Prelude (last, read)
-- Standard library imports.
import Control.Concurrent (threadDelay)
import Control.Concurrent.Chan
import Data.Aeson
import Data.Text (strip)
import System.Directory
import System.Exit (exitSuccess)
import Text.Printf
import System.Posix.Signals
import qualified Data.Map as Map
-- IHaskell imports.
import IHaskell.Convert (convert)
import IHaskell.Eval.Completion (complete)
import IHaskell.Eval.Evaluate
import IHaskell.Display
import IHaskell.Eval.Info
import IHaskell.Flags
import IHaskell.IPython
import IHaskell.Types
import IPython.ZeroMQ
import IPython.Types
import qualified Data.ByteString.Char8 as Chars
import qualified IPython.Message.UUID as UUID
import qualified IPython.Stdin as Stdin
-- GHC API imports.
import GHC hiding (extensions, language)
-- | Compute the GHC API version number using the dist/build/autogen/cabal_macros.h
ghcVersionInts :: [Int]
ghcVersionInts = map read . words . map dotToSpace $ VERSION_ghc
where dotToSpace '.' = ' '
dotToSpace x = x
main :: IO ()
main = do
args <- parseFlags <$> map unpack <$> getArgs
case args of
Left errorMessage ->
hPutStrLn stderr errorMessage
Right args ->
ihaskell args
chooseIPython [] = return DefaultIPython
chooseIPython (IPythonFrom path:_) =
ExplicitIPython <$> subHome path
chooseIPython (_:xs) = chooseIPython xs
ihaskell :: Args -> IO ()
-- If no mode is specified, print help text.
ihaskell (Args (ShowHelp help) _) =
putStrLn $ pack help
ihaskell (Args ConvertLhs args) = showingHelp ConvertLhs args $ convert args
ihaskell (Args Console flags) = showingHelp Console flags $ do
ipython <- chooseIPython flags
setupIPython ipython
flags <- addDefaultConfFile flags
info <- initInfo IPythonConsole flags
runConsole ipython info
ihaskell (Args mode@(View (Just fmt) (Just name)) args) = showingHelp mode args $ do
ipython <- chooseIPython args
nbconvert ipython fmt name
ihaskell (Args Notebook flags) = showingHelp Notebook flags $ do
ipython <- chooseIPython flags
setupIPython ipython
let server = case mapMaybe serveDir flags of
[] -> Nothing
xs -> Just $ last xs
flags <- addDefaultConfFile flags
undirInfo <- initInfo IPythonNotebook flags
curdir <- getCurrentDirectory
let info = undirInfo { initDir = curdir }
runNotebook ipython info server
where
serveDir (ServeFrom dir) = Just dir
serveDir _ = Nothing
ihaskell (Args (Kernel (Just filename)) _) = do
initInfo <- readInitInfo
runKernel filename initInfo
-- | Add a conf file to the arguments if none exists.
addDefaultConfFile :: [Argument] -> IO [Argument]
addDefaultConfFile flags = do
def <- defaultConfFile
case (find isConfFile flags, def) of
(Nothing, Just file) -> return $ ConfFile file : flags
_ -> return flags
where
isConfFile (ConfFile _) = True
isConfFile _ = False
showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO ()
showingHelp mode flags act =
case find (==Help) flags of
Just _ ->
putStrLn $ pack $ help mode
Nothing ->
act
-- | Parse initialization information from the flags.
initInfo :: FrontendType -> [Argument] -> IO InitInfo
initInfo front [] = return InitInfo { extensions = [], initCells = [], initDir = ".", frontend = front }
initInfo front (flag:flags) = do
info <- initInfo front flags
case flag of
Extension ext -> return info { extensions = ext:extensions info }
ConfFile filename -> do
cell <- readFile (fpFromText $ pack filename)
return info { initCells = cell:initCells info }
_ -> return info
-- | Run the IHaskell language kernel.
runKernel :: String -- ^ Filename of profile JSON file.
-> InitInfo -- ^ Initialization information from the invocation.
-> IO ()
runKernel profileSrc initInfo = do
setCurrentDirectory $ initDir initInfo
-- Parse the profile file.
Just profile <- liftM decode . readFile . fpFromText $ pack profileSrc
-- Necessary for `getLine` and their ilk to work.
dir <- getIHaskellDir
Stdin.recordKernelProfile dir profile
-- Serve on all sockets and ports defined in the profile.
interface <- serveProfile profile
-- Create initial state in the directory the kernel *should* be in.
state <- initialKernelState
modifyMVar_ state $ \kernelState -> return $
kernelState { getFrontend = frontend initInfo }
-- Receive and reply to all messages on the shell socket.
interpret True $ do
-- Ignore Ctrl-C the first time. This has to go inside the
-- `interpret`, because GHC API resets the signal handlers for some
-- reason (completely unknown to me).
liftIO ignoreCtrlC
-- Initialize the context by evaluating everything we got from the
-- command line flags. This includes enabling some extensions and also
-- running some code.
let extLines = map (":extension " ++) $ extensions initInfo
noPublish _ = return ()
evaluator line = do
-- Create a new state each time.
stateVar <- liftIO initialKernelState
state <- liftIO $ takeMVar stateVar
evaluate state line noPublish
mapM_ evaluator extLines
mapM_ evaluator $ initCells initInfo
forever $ do
-- Read the request from the request channel.
request <- liftIO $ readChan $ shellRequestChannel interface
-- Create a header for the reply.
replyHeader <- createReplyHeader (header request)
-- 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
let replier = writeChan (shellReplyChannel interface)
newState <- handleComm replier oldState request replyHeader
putMVar state newState
else do
-- Create the reply, possibly modifying kernel state.
oldState <- liftIO $ takeMVar state
(newState, reply) <- replyTo interface request replyHeader oldState
liftIO $ putMVar state newState
-- Write the reply to the reply channel.
liftIO $ writeChan (shellReplyChannel interface) reply
where
ignoreCtrlC =
installHandler keyboardSignal (CatchOnce $ putStrLn "Press Ctrl-C again to quit kernel.") Nothing
isCommMessage req = msgType (header req) `elem` [CommOpenMessage, CommDataMessage, CommCloseMessage]
-- Initial kernel state.
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
-- Generate a new message UUID.
newMessageId <- liftIO UUID.random
let repType = fromMaybe err (replyType $ msgType parent)
err = error $ "No reply for message " ++ show (msgType parent)
return MessageHeader {
identifiers = identifiers parent,
parentHeader = Just parent,
metadata = Map.fromList [],
messageId = newMessageId,
sessionId = sessionId parent,
username = username parent,
msgType = repType
}
-- | Compute a reply to a message.
replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpreter (KernelState, Message)
-- Reply to kernel info requests with a kernel info reply. No computation
-- needs to be done, as a kernel info reply is a static object (all info is
-- hard coded into the representation of that message type).
replyTo _ KernelInfoRequest{} replyHeader state =
return (state, KernelInfoReply {
header = replyHeader,
language = "haskell",
versionList = ghcVersionInts
})
-- Reply to a shutdown request by exiting the main thread.
-- Before shutdown, reply to the request to let the frontend know shutdown
-- is happening.
replyTo interface ShutdownRequest{restartPending = restartPending} replyHeader _ = liftIO $ do
writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader restartPending
exitSuccess
-- Reply to an execution request. The reply itself does not require
-- computation, but this causes messages to be sent to the IOPub socket
-- with the output of the code in the execution request.
replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
-- Convenience function to send a message to the IOPub socket.
let send msg = liftIO $ writeChan (iopubChannel interface) msg
-- Log things so that we can use stdin.
dir <- liftIO getIHaskellDir
liftIO $ Stdin.recordParentHeader dir $ header req
-- Notify the frontend that the kernel is busy computing.
-- All the headers are copies of the reply header with a different
-- message type, because this preserves the session ID, parent header,
-- and other important information.
busyHeader <- liftIO $ dupHeader replyHeader StatusMessage
send $ PublishStatus busyHeader Busy
-- Construct a function for publishing output as this is going.
-- This function accepts a boolean indicating whether this is the final
-- output and the thing to display. Store the final outputs in a list so
-- that when we receive an updated non-final output, we can clear the
-- entire output and re-display with the updated output.
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 outs
convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ encodeUtf8 svg
convertSvgToHtml x = x
makeSvgImg base64data = unpack $ "<img src=\"data:image/svg+xml;base64," ++ base64data ++ "\"/>"
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:))
-- If this has some pager output, store it for later.
let pager = pagerOut result
unless (null pager) $
modifyMVar_ pagerOutput (return . (++ pager ++ "\n"))
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 (unpack code) execCount
-- Run code and publish to the frontend as we go.
updatedState <- evaluate state (unpack code) publish
-- Notify the frontend that we're done computing.
idleHeader <- liftIO $ dupHeader replyHeader StatusMessage
send $ PublishStatus idleHeader Idle
pager <- liftIO $ readMVar pagerOutput
return (updatedState, ExecuteReply {
header = replyHeader,
pagerOutput = pager,
executionCounter = execCount,
status = Ok
})
replyTo _ req@CompleteRequest{} replyHeader state = do
let line = getCodeLine req
(matchedText, completions) <- complete (unpack line) (getCursorPos req)
let reply = CompleteReply replyHeader (map pack completions) (pack matchedText) line True
return (state, reply)
-- | Reply to the object_info_request message. Given an object name, return
-- | the associated type calculated by GHC.
replyTo _ ObjectInfoRequest{objectName = oname} replyHeader state = do
docs <- pack <$> info (unpack oname)
let reply = ObjectInfoReply {
header = replyHeader,
objectName = oname,
objectFound = strip docs /= "",
objectTypeString = docs,
objectDocString = docs
}
return (state, reply)
handleComm :: (Message -> IO ()) -> KernelState -> Message -> MessageHeader -> IO KernelState
handleComm replier kernelState req replyHeader = do
let widgets = openComms kernelState
uuid = commUuid req
dat = commData req
communicate value = do
head <- dupHeader replyHeader CommDataMessage
replier $ CommData head uuid value
case lookup uuid widgets of
Nothing -> fail $ "no widget with uuid " ++ show uuid
Just (Widget widget) ->
case msgType $ header req of
CommOpenMessage -> do
open widget dat communicate
return kernelState
CommDataMessage -> do
comm widget dat communicate
return kernelState
CommCloseMessage -> do
close widget dat
return kernelState { openComms = Map.delete uuid widgets }