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

Turn on and fix more warnings

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

@@ -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
       [] -> []
 

ghc-parser/ghc-parser.cabal

@@ -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:

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

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

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

@@ -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
 

ipython-kernel/ipython-kernel.cabal

 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       ,

ipython-kernel/src/IHaskell/IPython/EasyKernel.hs

@@ -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 }

ipython-kernel/src/IHaskell/IPython/Kernel.hs

@@ -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

ipython-kernel/src/IHaskell/IPython/Message/Parser.hs

@@ -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
 

ipython-kernel/src/IHaskell/IPython/Message/UUID.hs

@@ -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)

ipython-kernel/src/IHaskell/IPython/Message/Writer.hs

-{-# 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

ipython-kernel/src/IHaskell/IPython/Types.hs

@@ -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

ipython-kernel/src/IHaskell/IPython/ZeroMQ.hs

@@ -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

main/Main.hs

@@ -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

src/IHaskell/IPython/Stdin.hs

@@ -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
 

src/IHaskell/Types.hs

@@ -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 }

stack-8.0.yaml

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

stack-8.4.yaml

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

stack.yaml

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