mirrors/IHaskell
1
0
Fork 0
mirror of https://github.com/IHaskell/IHaskell.git synced 2025-04-18 20:36:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #928 from erikd/topic/warnings-other

Browse Source 
Turn on and fix more warnings
This commit is contained in:
Vaibhav Sagar 2018-09-01 21:15:39 -04:00 committed by GitHub
commit 726999ae1e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
18 changed files with 376 additions and 412 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

115
ghc-parser/generic-src/Language/Haskell/GHC/Parser.hs
View File

@ -31,15 +31,14 @@ import Bag
import ErrUtils hiding (ErrMsg)
import FastString
#if MIN_VERSION_ghc(8,4,0)
import GHC hiding (Located, Parsed)
import GHC hiding (Located, Parsed, parser)
#else
import GHC hiding (Located)
import GHC hiding (Located, parser)
#endif
import Lexer
import Lexer hiding (buffer)
import OrdList
import Outputable hiding ((<>))
import SrcLoc hiding (Located)
import StringBuffer
import qualified SrcLoc as SrcLoc
import StringBuffer hiding (len)
import qualified Language.Haskell.GHC.HappyParser as Parse
@ -74,12 +73,48 @@ data Located a = Located {
data Parser a = Parser (P a)
-- Our parsers.
parserStatement = Parser Parse.fullStatement
parserImport = Parser Parse.fullImport
parserDeclaration = Parser Parse.fullDeclaration
parserExpression = Parser Parse.fullExpression
parserTypeSignature = Parser Parse.fullTypeSignature
parserModule = Parser Parse.fullModule
#if MIN_VERSION_ghc(8,4,0)
parserStatement :: Parser (Maybe (LStmt GhcPs (LHsExpr GhcPs)))
#else
parserStatement :: Parser (Maybe (LStmt RdrName (LHsExpr RdrName)))
#endif
parserStatement = Parser Parse.fullStatement
#if MIN_VERSION_ghc(8,4,0)
parserImport :: Parser (LImportDecl GhcPs)
#else
parserImport :: Parser (LImportDecl RdrName)
#endif
parserImport = Parser Parse.fullImport
#if MIN_VERSION_ghc(8,4,0)
parserDeclaration :: Parser (OrdList (LHsDecl GhcPs))
#else
parserDeclaration :: Parser (OrdList (LHsDecl RdrName))
#endif
parserDeclaration = Parser Parse.fullDeclaration
#if MIN_VERSION_ghc(8,4,0)
parserExpression :: Parser (LHsExpr GhcPs)
#else
parserExpression :: Parser (LHsExpr RdrName)
#endif
parserExpression = Parser Parse.fullExpression
#if MIN_VERSION_ghc(8,4,0)
parserTypeSignature :: Parser (SrcLoc.Located (OrdList (LHsDecl GhcPs)))
#else
parserTypeSignature :: Parser (SrcLoc.Located (OrdList (LHsDecl RdrName)))
#endif
parserTypeSignature = Parser Parse.fullTypeSignature
#if MIN_VERSION_ghc(8,4,0)
parserModule :: Parser (SrcLoc.Located (HsModule GhcPs))
#else
parserModule :: Parser (SrcLoc.Located (HsModule RdrName))
#endif
parserModule = Parser Parse.fullModule
-- | Run a GHC parser on a string. Return success or failure with
-- associated information for both.
@ -87,7 +122,7 @@ runParser :: DynFlags -> Parser a -> String -> ParseOutput a
runParser flags (Parser parser) str =
-- Create an initial parser state.
let filename = "<interactive>"
location = mkRealSrcLoc (mkFastString filename) 1 1
location = SrcLoc.mkRealSrcLoc (mkFastString filename) 1 1
buffer = stringToStringBuffer str
parseState = mkPState flags buffer location in
-- Convert a GHC parser output into our own.
@ -95,48 +130,29 @@ runParser flags (Parser parser) str =
where
toParseOut :: ParseResult a -> ParseOutput a
#if MIN_VERSION_ghc(8,4,0)
toParseOut (PFailed _ span@(RealSrcSpan realSpan) err) =
toParseOut (PFailed _ spn@(RealSrcSpan realSpan) err) =
#else
toParseOut (PFailed span@(RealSrcSpan realSpan) err) =
toParseOut (PFailed spn@(RealSrcSpan realSpan) err) =
#endif
let errMsg = printErrorBag $ unitBag $ mkPlainErrMsg flags span err
line = srcLocLine $ realSrcSpanStart realSpan
col = srcLocCol $ realSrcSpanStart realSpan
in Failure errMsg $ Loc line col
let errMsg = printErrorBag $ unitBag $ mkPlainErrMsg flags spn err
ln = srcLocLine $ SrcLoc.realSrcSpanStart realSpan
col = srcLocCol $ SrcLoc.realSrcSpanStart realSpan
in Failure errMsg $ Loc ln col
#if MIN_VERSION_ghc(8,4,0)
toParseOut (PFailed _ span err) =
toParseOut (PFailed _ spn err) =
#else
toParseOut (PFailed span err) =
toParseOut (PFailed spn err) =
#endif
let errMsg = printErrorBag $ unitBag $ mkPlainErrMsg flags span err
let errMsg = printErrorBag $ unitBag $ mkPlainErrMsg flags spn err
in Failure errMsg $ Loc 0 0
toParseOut (POk parseState result) =
let parseEnd = realSrcSpanStart $ last_loc parseState
endLine = srcLocLine parseEnd
endCol = srcLocCol parseEnd
(before, after) = splitAtLoc endLine endCol str
in Parsed result
toParseOut (POk _parseState result) =
Parsed result
-- Convert the bag of errors into an error string.
printErrorBag bag = joinLines . map show $ bagToList bag
-- | Split a string at a given line and column. The column is included in
-- the second part of the split.
splitAtLoc :: LineNumber -> ColumnNumber -> String -> (String, String)
splitAtLoc line col string =
if line > length (lines string)
then (string, "")
else (before, after)
where
(beforeLines, afterLines) = splitAt line $ lines string
theLine = last beforeLines
(beforeChars, afterChars) = splitAt (col - 1) theLine
before = joinLines (init beforeLines) ++ '\n' : beforeChars
after = joinLines $ afterChars : afterLines
-- Not the same as 'unlines', due to trailing \n
joinLines :: [String] -> String
joinLines = intercalate "\n"
@ -151,7 +167,7 @@ layoutChunks :: String -> [Located String]
layoutChunks = joinQuasiquotes . go 1
where
go :: LineNumber -> String -> [Located String]
go line = filter (not . null . unloc) . map (fmap strip) . layoutLines line . lines
go ln = filter (not . null . unloc) . map (fmap strip) . layoutLines ln . lines
-- drop spaces on left and right
strip = dropRight . dropLeft
@ -165,13 +181,13 @@ layoutChunks = joinQuasiquotes . go 1
layoutLines _ [] = []
-- Use the indent of the first line to find the end of the first block.
layoutLines lineIdx all@(firstLine:rest) =
layoutLines lineIdx xs@(firstLine:rest) =
let firstIndent = indentLevel firstLine
blockEnded line = indentLevel line <= firstIndent in
blockEnded ln = indentLevel ln <= firstIndent in
case findIndex blockEnded rest of
-- If the first block doesn't end, return the whole string, since
-- that just means the block takes up the entire string.
Nothing -> [Located lineIdx $ intercalate "\n" all]
Nothing -> [Located lineIdx $ intercalate "\n" xs]
-- We found the end of the block. Split this bit out and recurse.
Just idx ->
@ -213,6 +229,7 @@ removeComments = removeOneLineComments . removeMultilineComments 0 0
where
dropLine = removeOneLineComments . dropWhile (/= '\n')
removeMultilineComments :: Int -> Int -> String -> String
removeMultilineComments nesting pragmaNesting str =
case str of
-- Don't remove comments after cmd directives
@ -253,8 +270,8 @@ removeComments = removeOneLineComments . removeMultilineComments 0 0
-- Take a part of a string that ends in an unescaped quote.
takeString str = case str of
escaped@('\\':'"':rest) -> escaped
'"':rest -> "\""
escaped@('\\':'"':_) -> escaped
'"':_ -> "\""
x:xs -> x:takeString xs
[] -> []

1
ghc-parser/ghc-parser.cabal
View File

@ -18,6 +18,7 @@ cabal-version: >=1.16
library
build-tools: happy, cpphs
ghc-options: -Wall
exposed-modules: Language.Haskell.GHC.Parser,
Language.Haskell.GHC.HappyParser
-- other-modules:

1
ghc-parser/src-8.0/Language/Haskell/GHC/HappyParser.hs
View File

@ -17,7 +17,6 @@ import HsSyn
import OrdList
-- compiler/parser
import RdrHsSyn
import Lexer
-- compiler/basicTypes

4
ghc-parser/src-8.4/Language/Haskell/GHC/HappyParser.hs
View File

@ -17,12 +17,8 @@ import HsSyn
import OrdList
-- compiler/parser
import RdrHsSyn
import Lexer
-- compiler/basicTypes
import RdrName
fullStatement :: P (Maybe (LStmt GhcPs (LHsExpr GhcPs)))
fullStatement = parseStmt

6
ipython-kernel/ipython-kernel.cabal
View File

@ -1,5 +1,5 @@
name: ipython-kernel
version: 0.9.1.0
version: 0.10.0.0
synopsis: A library for creating kernels for IPython frontends
description: ipython-kernel is a library for communicating with frontends for the interactive IPython framework. It is used extensively in IHaskell, the interactive Haskell environment.
@ -24,10 +24,11 @@ flag examples
library
ghc-options: -Wall
exposed-modules: IHaskell.IPython.Kernel
IHaskell.IPython.Types
IHaskell.IPython.ZeroMQ
IHaskell.IPython.Message.Writer
IHaskell.IPython.Message.Parser
IHaskell.IPython.Message.UUID
IHaskell.IPython.EasyKernel
@ -38,6 +39,7 @@ library
aeson ,
bytestring ,
cereal ,
cereal-text ,
containers ,
cryptonite ,
directory ,

45
ipython-kernel/src/IHaskell/IPython/EasyKernel.hs
View File

@ -23,7 +23,7 @@
-- logos, help text, and so forth.
module IHaskell.IPython.EasyKernel (easyKernel, installKernelspec, KernelConfig(..)) where
import Data.Aeson (decode, encode)
import Data.Aeson (decode, encode, toJSON)
import qualified Data.ByteString.Lazy as BL
@ -32,7 +32,7 @@ import System.Process (rawSystem)
import Control.Concurrent (MVar, readChan, writeChan, newMVar, readMVar, modifyMVar_)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad (forever, when, unless, void)
import Control.Monad (forever, when, void)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
@ -40,10 +40,8 @@ import qualified Data.Text as T
import IHaskell.IPython.Kernel
import IHaskell.IPython.Message.UUID as UUID
import IHaskell.IPython.Types
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist,
getHomeDirectory, getTemporaryDirectory)
import System.Directory (createDirectoryIfMissing, getTemporaryDirectory)
import System.FilePath ((</>))
import System.Exit (exitSuccess)
import System.IO (openFile, IOMode(ReadMode))
@ -53,7 +51,7 @@ import System.IO (openFile, IOMode(ReadMode))
-- running cells, and the type of final results of cells, respectively.
data KernelConfig m output result =
KernelConfig
{
{
-- | Info on the language of the kernel.
kernelLanguageInfo :: LanguageInfo
-- | Write all the files into the kernel directory, including `kernel.js`, `logo-64x64.svg`, and any
@ -122,19 +120,12 @@ createReplyHeader :: MonadIO m => MessageHeader -> m 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)
let repType = fromMaybe err (replyType $ mhMsgType parent)
err = error $ "No reply for message " ++ show (mhMsgType parent)
return $ MessageHeader (mhIdentifiers parent) (Just parent) (Map.fromList [])
newMessageId (mhSessionId parent) (mhUsername parent) repType
return
MessageHeader
{ identifiers = identifiers parent
, parentHeader = Just parent
, metadata = Map.fromList []
, messageId = newMessageId
, sessionId = sessionId parent
, username = username parent
, msgType = repType
}
-- | Execute an IPython kernel for a config. Your 'main' action should call this as the last thing
-- it does.
@ -145,16 +136,14 @@ easyKernel :: MonadIO m
-> m ()
easyKernel profileFile config = do
prof <- liftIO $ getProfile profileFile
zmq@(Channels shellReqChan shellRepChan ctrlReqChan ctrlRepChan iopubChan _) <- liftIO $ serveProfile
prof
False
zmq <- liftIO $ serveProfile prof False
execCount <- liftIO $ newMVar 0
forever $ do
req <- liftIO $ readChan shellReqChan
req <- liftIO $ readChan (shellRequestChannel zmq)
repHeader <- createReplyHeader (header req)
when (debug config) . liftIO $ print req
reply <- replyTo config execCount zmq req repHeader
liftIO $ writeChan shellRepChan reply
liftIO $ writeChan (shellRequestChannel zmq) reply
replyTo :: MonadIO m
=> KernelConfig m output result
@ -180,17 +169,17 @@ replyTo config _ interface KernelInfoRequest{} replyHeader = do
, status = Ok
}
replyTo config _ _ CommInfoRequest{} replyHeader =
replyTo _ _ _ CommInfoRequest{} replyHeader =
return
CommInfoReply
{ header = replyHeader
, commInfo = Map.empty }
replyTo config _ interface ShutdownRequest { restartPending = pending } replyHeader = do
replyTo _ _ interface ShutdownRequest { restartPending = pending } replyHeader = do
liftIO $ writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader pending
liftIO exitSuccess
replyTo config execCount interface req@ExecuteRequest { getCode = code } replyHeader = do
replyTo config execCount interface req@ExecuteRequest{} replyHeader = do
let send = writeChan (iopubChannel interface)
busyHeader <- dupHeader replyHeader StatusMessage
@ -205,7 +194,7 @@ replyTo config execCount interface req@ExecuteRequest { getCode = code } replyHe
send $ PublishDisplayData
outputHeader
(displayOutput config x)
in run config code clearOutput sendOutput
in run config (getCode req) clearOutput sendOutput
liftIO . send $ PublishDisplayData outputHeader (displayResult config res)
@ -254,4 +243,4 @@ dupHeader :: MonadIO m => MessageHeader -> MessageType -> m MessageHeader
dupHeader hdr mtype =
do
uuid <- liftIO UUID.random
return hdr { messageId = uuid, msgType = mtype }
return hdr { mhMessageId = uuid, mhMsgType = mtype }

1
ipython-kernel/src/IHaskell/IPython/Kernel.hs
View File

@ -3,7 +3,6 @@
module IHaskell.IPython.Kernel (module X) where
import IHaskell.IPython.Types as X
import IHaskell.IPython.Message.Writer as X
import IHaskell.IPython.Message.Parser as X
import IHaskell.IPython.Message.UUID as X
import IHaskell.IPython.ZeroMQ as X

21
ipython-kernel/src/IHaskell/IPython/Message/Parser.hs
View File

@ -8,15 +8,14 @@
-- the low-level 0MQ interface.
module IHaskell.IPython.Message.Parser (parseMessage) where
import Control.Applicative ((<|>), (<$>), (<*>))
import Data.Aeson ((.:), (.:?), (.!=), decode, Result(..), Object, Value(..))
import Data.Aeson.Types (parse, parseEither)
import Control.Applicative ((<$>), (<*>))
import Data.Aeson ((.:), (.:?), (.!=), decode, FromJSON, Result(..), Object, Value(..))
import Data.Aeson.Types (Parser, parse, parseEither)
import Data.ByteString hiding (unpack)
import qualified Data.ByteString.Lazy as Lazy
import Data.HashMap.Strict as HM
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text (Text, unpack)
import Debug.Trace
import IHaskell.IPython.Types
@ -32,7 +31,7 @@ parseMessage :: [ByteString] -- ^ The list of identifiers sent with the message.
-> Message -- ^ A parsed message.
parseMessage idents headerData parentHeader metadata content =
let header = parseHeader idents headerData parentHeader metadata
messageType = msgType header
messageType = mhMsgType header
messageWithoutHeader = parser messageType $ Lazy.fromStrict content
in messageWithoutHeader { header = header }
@ -43,15 +42,7 @@ parseHeader :: [ByteString] -- ^ The list of identifiers.
-> ByteString -- ^ The metadata, or "{}" for an empty map.
-> MessageHeader -- The resulting message header.
parseHeader idents headerData parentHeader metadata =
MessageHeader
{ identifiers = idents
, parentHeader = parentResult
, metadata = metadataMap
, messageId = messageUUID
, sessionId = sessionUUID
, username = username
, msgType = messageType
}
MessageHeader idents parentResult metadataMap messageUUID sessionUUID username messageType
where
-- Decode the header data and the parent header data into JSON objects. If the parent header data is
-- absent, just have Nothing instead.
@ -180,6 +171,7 @@ displayDataParser = requestParser $ \obj -> do
let displayDatas = makeDisplayDatas dataDict
return $ PublishDisplayData noHeader displayDatas
requestParser :: FromJSON a => (a -> Parser Message) -> LByteString -> Message
requestParser parser content =
case parseEither parser decoded of
Right parsed -> parsed
@ -218,6 +210,7 @@ inputMessageParser = requestParser $ \obj -> do
executionCount <- obj .: "execution_count"
return $ Input noHeader code executionCount
getDisplayDatas :: Maybe Object -> [DisplayData]
getDisplayDatas Nothing = []
getDisplayDatas (Just dataDict) = makeDisplayDatas dataDict

2
ipython-kernel/src/IHaskell/IPython/Message/UUID.hs
View File

@ -3,7 +3,7 @@
-- Generate, parse, and pretty print UUIDs for use with IPython.
module IHaskell.IPython.Message.UUID (UUID, random, randoms, uuidToString) where
import Control.Applicative ((<$>), (<*>))
import Control.Applicative ((<$>))
import Control.Monad (mzero, replicateM)
import Data.Aeson
import Data.Text (pack)

199
ipython-kernel/src/IHaskell/IPython/Message/Writer.hs
View File

@ -1,199 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-name-shadowing -fno-warn-unused-matches #-}
-- | Description : @ToJSON@ for Messages
--
-- This module contains the @ToJSON@ instance for @Message@.
module IHaskell.IPython.Message.Writer (ToJSON(..)) where
import Data.Aeson
import Data.Aeson.Types (Pair)
import Data.Aeson.Parser (json)
import Data.Map (Map)
import Data.Monoid (mempty)
import Data.Text (Text, pack)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Map as Map
import IHaskell.IPython.Types
import Data.Maybe (fromMaybe)
instance ToJSON LanguageInfo where
toJSON info = object
[ "name" .= languageName info
, "version" .= languageVersion info
, "file_extension" .= languageFileExtension info
, "codemirror_mode" .= languageCodeMirrorMode info
, "pygments_lexer" .= languagePygmentsLexer info
]
-- Convert message bodies into JSON.
instance ToJSON Message where
toJSON rep@KernelInfoReply{} =
object
[ "protocol_version" .= protocolVersion rep
, "banner" .= banner rep
, "implementation" .= implementation rep
, "implementation_version" .= implementationVersion rep
, "language_info" .= languageInfo rep
, "status" .= show (status rep)
]
toJSON CommInfoReply
{ header = header
, commInfo = commInfo
} =
object
[ "comms" .= Map.map (\comm -> object ["target_name" .= comm]) commInfo
, "status" .= string "ok"
]
toJSON ExecuteRequest
{ getCode = code
, getSilent = silent
, getStoreHistory = storeHistory
, getAllowStdin = allowStdin
, getUserExpressions = userExpressions
} =
object
[ "code" .= code
, "silent" .= silent
, "store_history" .= storeHistory
, "allow_stdin" .= allowStdin
, "user_expressions" .= userExpressions
]
toJSON ExecuteReply { status = status, executionCounter = counter, pagerOutput = pager } =
object
[ "status" .= show status
, "execution_count" .= counter
, "payload" .=
if null pager
then []
else mkPayload pager
, "user_expressions" .= emptyMap
]
where
mkPayload o = [ object
[ "source" .= string "page"
, "start" .= Number 0
, "data" .= object (map displayDataToJson o)
]
]
toJSON PublishStatus { executionState = executionState } =
object ["execution_state" .= executionState]
toJSON PublishStream { streamType = streamType, streamContent = content } =
object ["data" .= content, "name" .= streamType]
toJSON PublishDisplayData { displayData = datas } =
object
["metadata" .= object [], "data" .= object (map displayDataToJson datas)]
toJSON PublishOutput { executionCount = execCount, reprText = reprText } =
object
[ "data" .= object ["text/plain" .= reprText]
, "execution_count" .= execCount
, "metadata" .= object []
]
toJSON PublishInput { executionCount = execCount, inCode = code } =
object ["execution_count" .= execCount, "code" .= code]
toJSON (CompleteReply _ matches start end metadata status) =
object
[ "matches" .= matches
, "cursor_start" .= start
, "cursor_end" .= end
, "metadata" .= metadata
, "status" .= if status
then string "ok"
else "error"
]
toJSON i@InspectReply{} =
object
[ "status" .= if inspectStatus i
then string "ok"
else "error"
, "data" .= object (map displayDataToJson . inspectData $ i)
, "metadata" .= object []
, "found" .= inspectStatus i
]
toJSON ShutdownReply { restartPending = restart } =
object ["restart" .= restart
, "status" .= string "ok"
]
toJSON ClearOutput { wait = wait } =
object ["wait" .= wait]
toJSON RequestInput { inputPrompt = prompt } =
object ["prompt" .= prompt]
toJSON req@CommOpen{} =
object
[ "comm_id" .= commUuid req
, "target_name" .= commTargetName req
, "target_module" .= commTargetModule req
, "data" .= commData req
]
toJSON req@CommData{} =
object ["comm_id" .= commUuid req, "data" .= commData req]
toJSON req@CommClose{} =
object ["comm_id" .= commUuid req, "data" .= commData req]
toJSON req@HistoryReply{} =
object ["history" .= map tuplify (historyReply req)
, "status" .= string "ok"
]
where
tuplify (HistoryReplyElement sess linum res) = (sess, linum, case res of
Left inp -> toJSON inp
Right (inp, out) -> toJSON out)
toJSON req@IsCompleteReply{} =
object pairs
where
pairs =
case reviewResult req of
CodeComplete -> status "complete"
CodeIncomplete ind -> status "incomplete" ++ indent ind
CodeInvalid -> status "invalid"
CodeUnknown -> status "unknown"
status x = ["status" .= pack x]
indent x = ["indent" .= pack x]
toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body
-- | Print an execution state as "busy", "idle", or "starting".
instance ToJSON ExecutionState where
toJSON Busy = String "busy"
toJSON Idle = String "idle"
toJSON Starting = String "starting"
-- | Print a stream as "stdin" or "stdout" strings.
instance ToJSON StreamType where
toJSON Stdin = String "stdin"
toJSON Stdout = String "stdout"
-- | Convert a MIME type and value into a JSON dictionary pair.
displayDataToJson :: DisplayData -> (Text, Value)
displayDataToJson (DisplayData MimeJson dataStr) =
pack (show MimeJson) .= fromMaybe (String "") (decodeStrict (encodeUtf8 dataStr) :: Maybe Value)
displayDataToJson (DisplayData MimeVegalite dataStr) =
pack (show MimeVegalite) .= fromMaybe (String "") (decodeStrict (encodeUtf8 dataStr) :: Maybe Value)
displayDataToJson (DisplayData MimeVega dataStr) =
pack (show MimeVega) .= fromMaybe (String "") (decodeStrict (encodeUtf8 dataStr) :: Maybe Value)
displayDataToJson (DisplayData mimeType dataStr) =
pack (show mimeType) .= String dataStr
----- Constants -----
emptyMap :: Map String String
emptyMap = mempty
emptyList :: [Int]
emptyList = []
ints :: [Int] -> [Int]
ints = id
string :: String -> String
string = id

230
ipython-kernel/src/IHaskell/IPython/Types.hs
View File

@ -6,8 +6,8 @@ module IHaskell.IPython.Types (
-- * IPython kernel profile
Profile(..),
Transport(..),
Port(..),
IP(..),
Port,
IP,
-- * IPython kernelspecs
KernelSpec(..),
@ -15,12 +15,12 @@ module IHaskell.IPython.Types (
-- * IPython messaging protocol
Message(..),
MessageHeader(..),
Username(..),
Metadata(..),
Username,
Metadata,
MessageType(..),
CodeReview(..),
Width(..),
Height(..),
Width,
Height,
StreamType(..),
ExecutionState(..),
ExecuteReplyStatus(..),
@ -38,11 +38,15 @@ module IHaskell.IPython.Types (
import Control.Applicative ((<$>), (<*>))
import Data.Aeson
import Data.Aeson.Types (typeMismatch)
import Data.ByteString (ByteString)
import Data.List (find)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Serialize
import Data.Text (Text)
import Data.Serialize.Text ()
import Data.Text (Text, pack)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Typeable
@ -117,7 +121,7 @@ instance ToJSON Transport where
-------------------- IPython Kernelspec Types ----------------------
data KernelSpec =
KernelSpec
{
{
-- | Name shown to users to describe this kernel (e.g. "Haskell")
kernelDisplayName :: String
-- | Name for the kernel; unique kernel identifier (e.g. "haskell")
@ -140,13 +144,13 @@ instance ToJSON KernelSpec where
-- | A message header with some metadata.
data MessageHeader =
MessageHeader
{ identifiers :: [ByteString] -- ^ The identifiers sent with the message.
, parentHeader :: Maybe MessageHeader -- ^ The parent header, if present.
, metadata :: Metadata -- ^ A dict of metadata.
, messageId :: UUID -- ^ A unique message UUID.
, sessionId :: UUID -- ^ A unique session UUID.
, username :: Username -- ^ The user who sent this message.
, msgType :: MessageType -- ^ The message type.
{ mhIdentifiers :: [ByteString] -- ^ The identifiers sent with the message.
, mhParentHeader :: Maybe MessageHeader -- ^ The parent header, if present.
, mhMetadata :: Metadata -- ^ A dict of metadata.
, mhMessageId :: UUID -- ^ A unique message UUID.
, mhSessionId :: UUID -- ^ A unique session UUID.
, mhUsername :: Username -- ^ The user who sent this message.
, mhMsgType :: MessageType -- ^ The message type.
}
deriving (Show, Read)
@ -154,11 +158,11 @@ data MessageHeader =
-- all the record fields.
instance ToJSON MessageHeader where
toJSON header = object
[ "msg_id" .= messageId header
, "session" .= sessionId header
, "username" .= username header
[ "msg_id" .= mhMessageId header
, "session" .= mhSessionId header
, "username" .= mhUsername header
, "version" .= ("5.0" :: String)
, "msg_type" .= showMessageType (msgType header)
, "msg_type" .= showMessageType (mhMsgType header)
]
-- | A username for the source of a message.
@ -280,6 +284,15 @@ data LanguageInfo =
}
deriving (Show, Eq)
instance ToJSON LanguageInfo where
toJSON info = object
[ "name" .= languageName info
, "version" .= languageVersion info
, "file_extension" .= languageFileExtension info
, "codemirror_mode" .= languageCodeMirrorMode info
, "pygments_lexer" .= languagePygmentsLexer info
]
data CodeReview = CodeComplete
| CodeIncomplete String -- ^ String to be used to indent next line of input
| CodeInvalid
@ -472,6 +485,146 @@ data Message =
| SendNothing -- Dummy message; nothing is sent.
deriving Show
-- Convert message bodies into JSON.
instance ToJSON Message where
toJSON rep@KernelInfoReply{} =
object
[ "protocol_version" .= protocolVersion rep
, "banner" .= banner rep
, "implementation" .= implementation rep
, "implementation_version" .= implementationVersion rep
, "language_info" .= languageInfo rep
, "status" .= show (status rep)
]
toJSON CommInfoReply
{ header = header
, commInfo = commInfo
} =
object
[ "comms" .= Map.map (\comm -> object ["target_name" .= comm]) commInfo
, "status" .= string "ok"
]
toJSON ExecuteRequest
{ getCode = code
, getSilent = silent
, getStoreHistory = storeHistory
, getAllowStdin = allowStdin
, getUserExpressions = userExpressions
} =
object
[ "code" .= code
, "silent" .= silent
, "store_history" .= storeHistory
, "allow_stdin" .= allowStdin
, "user_expressions" .= userExpressions
]
toJSON ExecuteReply { status = status, executionCounter = counter, pagerOutput = pager } =
object
[ "status" .= show status
, "execution_count" .= counter
, "payload" .=
if null pager
then []
else mkPayload pager
, "user_expressions" .= emptyMap
]
where
mkPayload o = [ object
[ "source" .= string "page"
, "start" .= Number 0
, "data" .= object (map displayDataToJson o)
]
]
toJSON PublishStatus { executionState = executionState } =
object ["execution_state" .= executionState]
toJSON PublishStream { streamType = streamType, streamContent = content } =
object ["data" .= content, "name" .= streamType]
toJSON PublishDisplayData { displayData = datas } =
object
["metadata" .= object [], "data" .= object (map displayDataToJson datas)]
toJSON PublishOutput { executionCount = execCount, reprText = reprText } =
object
[ "data" .= object ["text/plain" .= reprText]
, "execution_count" .= execCount
, "metadata" .= object []
]
toJSON PublishInput { executionCount = execCount, inCode = code } =
object ["execution_count" .= execCount, "code" .= code]
toJSON (CompleteReply _ matches start end metadata status) =
object
[ "matches" .= matches
, "cursor_start" .= start
, "cursor_end" .= end
, "metadata" .= metadata
, "status" .= if status
then string "ok"
else "error"
]
toJSON i@InspectReply{} =
object
[ "status" .= if inspectStatus i
then string "ok"
else "error"
, "data" .= object (map displayDataToJson . inspectData $ i)
, "metadata" .= object []
, "found" .= inspectStatus i
]
toJSON ShutdownReply { restartPending = restart } =
object ["restart" .= restart
, "status" .= string "ok"
]
toJSON ClearOutput { wait = wait } =
object ["wait" .= wait]
toJSON RequestInput { inputPrompt = prompt } =
object ["prompt" .= prompt]
toJSON req@CommOpen{} =
object
[ "comm_id" .= commUuid req
, "target_name" .= commTargetName req
, "target_module" .= commTargetModule req
, "data" .= commData req
]
toJSON req@CommData{} =
object ["comm_id" .= commUuid req, "data" .= commData req]
toJSON req@CommClose{} =
object ["comm_id" .= commUuid req, "data" .= commData req]
toJSON req@HistoryReply{} =
object ["history" .= map tuplify (historyReply req)
, "status" .= string "ok"
]
where
tuplify (HistoryReplyElement sess linum res) = (sess, linum, case res of
Left inp -> toJSON inp
Right (inp, out) -> toJSON out)
toJSON req@IsCompleteReply{} =
object pairs
where
pairs =
case reviewResult req of
CodeComplete -> status "complete"
CodeIncomplete ind -> status "incomplete" ++ indent ind
CodeInvalid -> status "invalid"
CodeUnknown -> status "unknown"
status x = ["status" .= pack x]
indent x = ["indent" .= pack x]
toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body
-- | Ways in which the frontend can request history. TODO: Implement fields as described in
-- messaging spec.
data HistoryAccessType = HistoryRange
@ -497,6 +650,7 @@ instance FromJSON ExecuteReplyStatus where
parseJSON (String "ok") = return Ok
parseJSON (String "error") = return Err
parseJSON (String "abort") = return Abort
parseJSON invalid = typeMismatch "ExecuteReplyStatus" invalid
instance Show ExecuteReplyStatus where
show Ok = "ok"
@ -513,6 +667,13 @@ instance FromJSON ExecutionState where
parseJSON (String "busy") = return Busy
parseJSON (String "idle") = return Idle
parseJSON (String "starting") = return Starting
parseJSON invalid = typeMismatch "ExecutionState" invalid
-- | Print an execution state as "busy", "idle", or "starting".
instance ToJSON ExecutionState where
toJSON Busy = String "busy"
toJSON Idle = String "idle"
toJSON Starting = String "starting"
-- | Input and output streams.
data StreamType = Stdin
@ -524,6 +685,13 @@ instance FromJSON StreamType where
parseJSON (String "stdin") = return Stdin
parseJSON (String "stdout") = return Stdout
parseJSON (String "stderr") = return Stderr
parseJSON invalid = typeMismatch "StreamType" invalid
-- | Print a stream as "stdin" or "stdout" strings.
instance ToJSON StreamType where
toJSON Stdin = String "stdin"
toJSON Stdout = String "stdout"
toJSON Stderr = String "stderr"
-- | Get the reply message type for a request message type.
replyType :: MessageType -> Maybe MessageType
@ -547,11 +715,6 @@ data DisplayData = DisplayData MimeType Text
instance Show DisplayData where
show _ = "DisplayData"
-- Allow DisplayData serialization
instance Serialize Text where
put str = put (Text.encodeUtf8 str)
get = Text.decodeUtf8 <$> get
instance Serialize DisplayData
instance Serialize MimeType
@ -583,6 +746,7 @@ extractPlain disps =
case find isPlain disps of
Nothing -> ""
Just (DisplayData PlainText bytestr) -> Text.unpack bytestr
Just _ -> ""
where
isPlain (DisplayData mime _) = mime == PlainText
@ -617,3 +781,21 @@ instance Read MimeType where
readsPrec _ "application/vnd.vega.v2+json" = [(MimeVega, "")]
readsPrec _ "application/vnd.vegalite.v1+json" = [(MimeVegalite, "")]
readsPrec _ "application/vdom.v1+json" = [(MimeVdom, "")]
readsPrec _ _ = []
-- | Convert a MIME type and value into a JSON dictionary pair.
displayDataToJson :: DisplayData -> (Text, Value)
displayDataToJson (DisplayData MimeJson dataStr) =
pack (show MimeJson) .= fromMaybe (String "") (decodeStrict (Text.encodeUtf8 dataStr) :: Maybe Value)
displayDataToJson (DisplayData MimeVegalite dataStr) =
pack (show MimeVegalite) .= fromMaybe (String "") (decodeStrict (Text.encodeUtf8 dataStr) :: Maybe Value)
displayDataToJson (DisplayData MimeVega dataStr) =
pack (show MimeVega) .= fromMaybe (String "") (decodeStrict (Text.encodeUtf8 dataStr) :: Maybe Value)
displayDataToJson (DisplayData mimeType dataStr) =
pack (show mimeType) .= String dataStr
string :: String -> String
string = id
emptyMap :: Map String String
emptyMap = mempty

124
ipython-kernel/src/IHaskell/IPython/ZeroMQ.hs
View File

@ -27,11 +27,10 @@ import qualified Data.ByteString.Lazy as LBS
import Data.Char
import Data.Monoid ((<>))
import qualified Data.Text.Encoding as Text
import System.ZMQ4 as ZMQ4 hiding (stdin)
import System.ZMQ4 as ZMQ4
import Text.Read (readMaybe)
import IHaskell.IPython.Message.Parser
import IHaskell.IPython.Message.Writer ()
import IHaskell.IPython.Types
-- | The channel interface to the ZeroMQ sockets. All communication is done via Messages, which are
@ -39,7 +38,7 @@ import IHaskell.IPython.Types
-- should functionally serve as high-level sockets which speak Messages instead of ByteStrings.
data ZeroMQInterface =
Channels
{
{
-- | A channel populated with requests from the frontend.
shellRequestChannel :: Chan Message
-- | Writing to this channel causes a reply to be sent to the frontend.
@ -90,16 +89,16 @@ serveProfile profile debug = do
-- Create the context in a separate thread that never finishes. If withContext or withSocket
-- complete, the context or socket become invalid.
forkIO $ withContext $ \context -> do
_ <- forkIO $ withContext $ \ctxt -> do
-- Serve on all sockets.
forkIO $ serveSocket context Rep (hbPort profile) $ heartbeat channels
forkIO $ serveSocket context Router (controlPort profile) $ control debug channels
forkIO $ serveSocket context Router (shellPort profile) $ shell debug channels
_ <- forkIO $ serveSocket ctxt Rep (hbPort profile) $ heartbeat channels
_ <- forkIO $ serveSocket ctxt Router (controlPort profile) $ control debug channels
_ <- forkIO $ serveSocket ctxt Router (shellPort profile) $ shell debug channels
-- The context is reference counted in this thread only. Thus, the last serveSocket cannot be
-- asynchronous, because otherwise context would be garbage collectable - since it would only be
-- The ctxt is reference counted in this thread only. Thus, the last serveSocket cannot be
-- asynchronous, because otherwise ctxt would be garbage collectable - since it would only be
-- used in other threads. Thus, keep the last serveSocket in this thread.
serveSocket context Pub (iopubPort profile) $ iopub debug channels
serveSocket ctxt Pub (iopubPort profile) $ iopub debug channels
return channels
@ -132,9 +131,9 @@ parsePort s = readMaybe num
num = reverse (takeWhile isNumber (reverse s))
bindLocalEphemeralPort :: Socket a -> IO Int
bindLocalEphemeralPort socket = do
bind socket $ "tcp://127.0.0.1:*"
endpointString <- lastEndpoint socket
bindLocalEphemeralPort sock = do
bind sock $ "tcp://127.0.0.1:*"
endpointString <- lastEndpoint sock
case parsePort endpointString of
Nothing ->
fail $ "internalError: IHaskell.IPython.ZeroMQ.bindLocalEphemeralPort encountered a port index that could not be interpreted as an int."
@ -152,19 +151,19 @@ withEphemeralPorts :: ByteString -- ^ HMAC encryption key
withEphemeralPorts key debug callback = do
channels <- newZeroMQInterface key
-- Create the ZMQ4 context
withContext $ \context -> do
withContext $ \ctxt -> do
-- Create the sockets to communicate with.
withSocket context Rep $ \heartbeatSocket -> do
withSocket context Router $ \controlportSocket -> do
withSocket context Router $ \shellportSocket -> do
withSocket context Pub $ \iopubSocket -> do
withSocket ctxt Rep $ \heartbeatSocket -> do
withSocket ctxt Router $ \controlportSocket -> do
withSocket ctxt Router $ \shellportSocket -> do
withSocket ctxt Pub $ \iopubSocket -> do
-- Bind each socket to a local port, getting the port chosen.
hbPort <- bindLocalEphemeralPort heartbeatSocket
controlPort <- bindLocalEphemeralPort controlportSocket
shellPort <- bindLocalEphemeralPort shellportSocket
iopubPort <- bindLocalEphemeralPort iopubSocket
hbPt <- bindLocalEphemeralPort heartbeatSocket
controlPt <- bindLocalEphemeralPort controlportSocket
shellPt <- bindLocalEphemeralPort shellportSocket
iopubPt <- bindLocalEphemeralPort iopubSocket
-- Create object to store ephemeral ports
let ports = ZeroMQEphemeralPorts { ephHbPort = hbPort, ephControlPort = controlPort, ephShellPort = shellPort, ephIOPubPort = iopubPort, ephSignatureKey = key }
let ports = ZeroMQEphemeralPorts hbPt controlPt shellPt iopubPt key
-- Launch actions to listen to communicate between channels and cockets.
_ <- forkIO $ forever $ heartbeat channels heartbeatSocket
_ <- forkIO $ forever $ control debug channels controlportSocket
@ -180,44 +179,44 @@ serveStdin profile = do
-- Create the context in a separate thread that never finishes. If withContext or withSocket
-- complete, the context or socket become invalid.
forkIO $ withContext $ \context ->
_ <- forkIO $ withContext $ \ctxt ->
-- Serve on all sockets.
serveSocket context Router (stdinPort profile) $ \socket -> do
serveSocket ctxt Router (stdinPort profile) $ \sock -> do
-- Read the request from the interface channel and send it.
readChan reqChannel >>= sendMessage False (signatureKey profile) socket
readChan reqChannel >>= sendMessage False (signatureKey profile) sock
-- Receive a response and write it to the interface channel.
receiveMessage False socket >>= writeChan repChannel
receiveMessage False sock >>= writeChan repChannel
return $ StdinChannel reqChannel repChannel
-- | Serve on a given socket in a separate thread. Bind the socket in the | given context and then
-- loop the provided action, which should listen | on the socket and respond to any events.
-- | Serve on a given sock in a separate thread. Bind the sock in the | given context and then
-- loop the provided action, which should listen | on the sock and respond to any events.
serveSocket :: SocketType a => Context -> a -> Port -> (Socket a -> IO b) -> IO ()
serveSocket context socketType port action = void $
withSocket context socketType $ \socket -> do
bind socket $ "tcp://127.0.0.1:" ++ show port
forever $ action socket
serveSocket ctxt socketType port action = void $
withSocket ctxt socketType $ \sock -> do
bind sock $ "tcp://127.0.0.1:" ++ show port
forever $ action sock
-- | Listener on the heartbeat port. Echoes back any data it was sent.
heartbeat :: ZeroMQInterface -> Socket Rep -> IO ()
heartbeat _ socket = do
heartbeat _ sock = do
-- Read some data.
request <- receive socket
request <- receive sock
-- Send it back.
send socket [] request
send sock [] request
-- | Listener on the shell port. Reads messages and writes them to | the shell request channel. For
-- each message, reads a response from the | shell reply channel of the interface and sends it back
-- to the frontend.
shell :: Bool -> ZeroMQInterface -> Socket Router -> IO ()
shell debug channels socket = do
shell debug channels sock = do
-- Receive a message and write it to the interface channel.
receiveMessage debug socket >>= writeChan requestChannel
receiveMessage debug sock >>= writeChan requestChannel
-- Read the reply from the interface channel and send it.
readChan replyChannel >>= sendMessage debug (hmacKey channels) socket
readChan replyChannel >>= sendMessage debug (hmacKey channels) sock
where
requestChannel = shellRequestChannel channels
@ -227,12 +226,12 @@ shell debug channels socket = do
-- each message, reads a response from the | shell reply channel of the interface and sends it back
-- to the frontend.
control :: Bool -> ZeroMQInterface -> Socket Router -> IO ()
control debug channels socket = do
control debug channels sock = do
-- Receive a message and write it to the interface channel.
receiveMessage debug socket >>= writeChan requestChannel
receiveMessage debug sock >>= writeChan requestChannel
-- Read the reply from the interface channel and send it.
readChan replyChannel >>= sendMessage debug (hmacKey channels) socket
readChan replyChannel >>= sendMessage debug (hmacKey channels) sock
where
requestChannel = controlRequestChannel channels
@ -241,33 +240,33 @@ control debug channels socket = do
-- | Send messages via the iopub channel. | This reads messages from the ZeroMQ iopub interface
-- channel | and then writes the messages to the socket.
iopub :: Bool -> ZeroMQInterface -> Socket Pub -> IO ()
iopub debug channels socket =
readChan (iopubChannel channels) >>= sendMessage debug (hmacKey channels) socket
iopub debug channels sock =
readChan (iopubChannel channels) >>= sendMessage debug (hmacKey channels) sock
-- | Attempt to send a message along the socket, returning true if successful.
trySendMessage :: Sender a => String -> Bool -> ByteString -> Socket a -> Message -> IO Bool
trySendMessage nm debug hmacKey socket message = do
trySendMessage _ debug hmackey sock msg = do
let zmqErrorHandler :: ZMQError -> IO Bool
zmqErrorHandler e
-- Ignore errors if we cannot send. We may want to forward this to the thread that tried put the
-- message in the Chan initially.
| errno e == 38 = return False
| otherwise = throwIO e
(sendMessage debug hmacKey socket message >> return True) `catch` zmqErrorHandler
(sendMessage debug hmackey sock msg >> return True) `catch` zmqErrorHandler
-- | Send messages via the iopub channel. This reads messages from the ZeroMQ iopub interface
-- channel and then writes the messages to the socket. This is a checked implementation which will
-- stop if the socket is closed.
checkedIOpub :: Bool -> ZeroMQInterface -> Socket Pub -> IO ()
checkedIOpub debug channels socket = do
checkedIOpub debug channels sock = do
msg <- readChan (iopubChannel channels)
cont <- trySendMessage "io" debug (hmacKey channels) socket msg
cont <- trySendMessage "io" debug (hmacKey channels) sock msg
when cont $
checkedIOpub debug channels socket
checkedIOpub debug channels sock
-- | Receive and parse a message from a socket.
receiveMessage :: Receiver a => Bool -> Socket a -> IO Message
receiveMessage debug socket = do
receiveMessage debug sock = do
-- Read all identifiers until the identifier/message delimiter.
idents <- readUntil "<IDS|MSG>"
@ -285,12 +284,11 @@ receiveMessage debug socket = do
putStr "Content: "
Char.putStrLn content
let message = parseMessage idents headerData parentHeader metadata content
return message
return $ parseMessage idents headerData parentHeader metadata content
where
-- Receive the next piece of data from the socket.
next = receive socket
next = receive sock
-- Read data from the socket until we hit an ending string. Return all data as a list, which does
-- not include the ending string.
@ -306,10 +304,10 @@ receiveMessage debug socket = do
-- socket. Sign it using HMAC with SHA-256 using the provided key.
sendMessage :: Sender a => Bool -> ByteString -> Socket a -> Message -> IO ()
sendMessage _ _ _ SendNothing = return ()
sendMessage debug hmacKey socket message = do
sendMessage debug hmackey sock msg = do
when debug $ do
putStr "Message: "
print message
print msg
putStr "Sent: "
print content
@ -325,8 +323,8 @@ sendMessage debug hmacKey socket message = do
sendLast content
where
sendPiece = send socket [SendMore]
sendLast = send socket []
sendPiece = send sock [SendMore]
sendLast = send sock []
-- Encode to a strict bytestring.
encodeStrict :: ToJSON a => a -> ByteString
@ -338,12 +336,12 @@ sendMessage debug hmacKey socket message = do
-- Compute the HMAC SHA-256 signature of a bytestring message.
hmac :: ByteString -> ByteString
hmac = Char.pack . show . (HMAC.hmacGetDigest :: HMAC.HMAC SHA256 -> Hash.Digest SHA256) . HMAC.hmac hmacKey
hmac = Char.pack . show . (HMAC.hmacGetDigest :: HMAC.HMAC SHA256 -> Hash.Digest SHA256) . HMAC.hmac hmackey
-- Pieces of the message.
head = header message
parentHeaderStr = maybe "{}" encodeStrict $ parentHeader head
idents = identifiers head
hdr = header msg
parentHeaderStr = maybe "{}" encodeStrict $ mhParentHeader hdr
idents = mhIdentifiers hdr
metadata = "{}"
content = encodeStrict message
headStr = encodeStrict head
content = encodeStrict msg
headStr = encodeStrict hdr

20
main/Main.hs
View File

@ -195,7 +195,7 @@ runKernel kOpts profileSrc = do
installHandler keyboardSignal (CatchOnce $ putStrLn "Press Ctrl-C again to quit kernel.")
Nothing
isCommMessage req = msgType (header req) `elem` [CommDataMessage, CommCloseMessage]
isCommMessage req = mhMsgType (header req) `elem` [CommDataMessage, CommCloseMessage]
-- Initial kernel state.
initialKernelState :: IO (MVar KernelState)
@ -206,19 +206,11 @@ 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)
let repType = fromMaybe err (replyType $ mhMsgType parent)
err = error $ "No reply for message " ++ show (mhMsgType parent)
return
MessageHeader
{ identifiers = identifiers parent
, parentHeader = Just parent
, metadata = Map.fromList []
, messageId = newMessageId
, sessionId = sessionId parent
, username = username parent
, msgType = repType
}
return $ MessageHeader (mhIdentifiers parent) (Just parent) mempty
newMessageId (mhSessionId parent) (mhUsername parent) repType
-- | Compute a reply to a message.
replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpreter (KernelState, Message)
@ -432,7 +424,7 @@ handleComm send kernelState req replyHeader = do
newState <- case Map.lookup uuid widgets of
Nothing -> return kernelState
Just (Widget widget) ->
case msgType $ header req of
case mhMsgType $ header req of
CommDataMessage -> do
disp <- run $ comm widget dat communicate
pgrOut <- liftIO $ readMVar pOut

12
src/IHaskell/IPython/Stdin.hs
View File

@ -33,7 +33,6 @@ import GHC.IO.Handle
import GHC.IO.Handle.Types
import System.Posix.IO
import System.IO.Unsafe
import qualified Data.Map as Map
import IHaskell.IPython.Types
import IHaskell.IPython.ZeroMQ
@ -88,15 +87,8 @@ getInputLine dir = do
-- Send a request for input.
uuid <- UUID.random
parentHdr <- fromJust . readMay <$> readFile (dir ++ "/.last-req-header")
let hdr = MessageHeader
{ username = username parentHdr
, identifiers = identifiers parentHdr
, parentHeader = Just parentHdr
, messageId = uuid
, sessionId = sessionId parentHdr
, metadata = Map.fromList []
, msgType = InputRequestMessage
}
let hdr = MessageHeader (mhIdentifiers parentHdr) (Just parentHdr) mempty
uuid (mhSessionId parentHdr) (mhUsername parentHdr) InputRequestMessage
let msg = RequestInput hdr ""
writeChan req msg

4
src/IHaskell/Types.hs
View File

@ -39,7 +39,7 @@ module IHaskell.Types (
import IHaskellPrelude
import Data.Aeson (ToJSON, Value, (.=), object)
import Data.Aeson (ToJSON (..), Value, (.=), object)
import Data.Function (on)
import Data.Serialize
import GHC.Generics
@ -268,4 +268,4 @@ dupHeader :: MessageHeader -> MessageType -> IO MessageHeader
dupHeader hdr messageType = do
uuid <- liftIO random
return hdr { messageId = uuid, msgType = messageType }
return hdr { mhMessageId = uuid, mhMsgType = messageType }

1
stack-8.0.yaml
View File

@ -21,6 +21,7 @@ extra-deps: []
ghc-options:
# Eventually we want "$locals": -Wall -Werror
ghc-parser: -Wall -Werror
ihaskell: -Wall -Werror
nix:

1
stack-8.4.yaml
View File

@ -25,6 +25,7 @@ extra-deps:
ghc-options:
# Eventually we want "$locals": -Wall -Werror
ghc-parser: -Wall -Werror
ihaskell: -Wall -Werror
nix:

1
stack.yaml
View File

@ -19,6 +19,7 @@ packages:
ghc-options:
# Eventually we want "$locals": -Wall -Werror
ghc-parser: -Wall -Werror
ihaskell: -Wall -Werror
allow-newer: true