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

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