Add support for GHC JSON diagnostics

cabal.project

@@ -1,7 +1,7 @@
 packages:
   sensei.cabal
 
-package sensei
+program-options
   ghc-options: -Werror
 
 tests: True

src/GHC/Diagnostic.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE DeriveAnyClass #-}
+module GHC.Diagnostic where
+
+import Prelude hiding (span)
+import GHC.Generics
+import Data.Aeson (ToJSON(..), FromJSON(..))
+import Data.ByteString (ByteString)
+import Data.ByteString.Builder (Builder)
+import qualified Data.ByteString.Builder as Builder
+import Data.ByteString.Lazy (toStrict)
+
+data Diagnostic = Diagnostic {
+  version :: String
+, ghcVersion :: String
+, span :: Span
+, severity :: Severity
+, code :: Maybe Int
+, message :: [String]
+, hints :: [String]
+} deriving (Eq, Show, Generic, ToJSON, FromJSON)
+
+data Span = Span {
+  file :: FilePath
+, start :: Location
+, end :: Location
+} deriving (Eq, Show, Generic, ToJSON, FromJSON)
+
+data Location = Location {
+  line :: Int
+, column :: Int
+} deriving (Eq, Show, Generic, ToJSON, FromJSON)
+
+data Severity = Warning | Error
+  deriving (Eq, Show, Generic, ToJSON, FromJSON)
+
+format :: Diagnostic -> ByteString
+format diagnostic = toStrict . Builder.toLazyByteString $ Builder.stringUtf8 diagnostic.span.file <> ":" <> Builder.intDec start.line <> ":" <> Builder.intDec start.column <> ": " <> foo <> code <> Builder.stringUtf8 (unlines diagnostic.message) <> "\n"
+  where
+    span = diagnostic.span
+    start = span.start
+
+    code :: Builder
+    code = case diagnostic.code of
+      Nothing -> ""
+      Just c -> "[GHC-" <> Builder.intDec c <> "] "
+
+    foo = case diagnostic.severity of
+      Warning -> "warning: "
+      Error -> "error: "

src/HTTP.hs

@@ -22,6 +22,9 @@ import           Network.Wai.Handler.Warp (runSettingsSocket, defaultSettings)
 import           Network.Socket
 
 import qualified Trigger
+import           GHC.Diagnostic
+
+import           Data.Aeson
 
 socketName :: FilePath -> String
 socketName dir = dir </> ".sensei.sock"
@@ -35,8 +38,8 @@ newSocket = socket AF_UNIX Stream 0
 withSocket :: (Socket -> IO a) -> IO a
 withSocket = bracket newSocket close
 
-withServer :: FilePath -> IO (Trigger.Result, String) -> IO a -> IO a
-withServer dir trigger = withApplication dir (app trigger)
+withServer :: FilePath -> IO (Trigger.Result, String, [Diagnostic]) -> IO a -> IO a
+withServer dir = withApplication dir . app
 
 withApplication :: FilePath -> Application -> IO a -> IO a
 withApplication dir application action = do
@@ -59,8 +62,12 @@ withThread asyncAction action = do
   takeMVar mvar
   return r
 
-app :: IO (Trigger.Result, String) -> Application
-app trigger request respond = trigger >>= textPlain
+app :: IO (Trigger.Result, String, [Diagnostic]) -> Application
+app getLastResult request respond = case pathInfo request of
+  ["diagnostics"] -> do
+    (_, _, diagnostics) <- getLastResult
+    respond $ json diagnostics
+  _ -> getLastResult >>= textPlain
   where
     color :: Either ByteString Bool
     color = case join $ lookup "color" $ queryString request of
@@ -69,8 +76,8 @@ app trigger request respond = trigger >>= textPlain
       Just "true" -> Right True
       Just value -> Left $ "invalid value for color: " <> urlEncode True value
 
-    textPlain :: (Trigger.Result, FilePath) -> IO ResponseReceived
-    textPlain (result, xs) = case color of
+    textPlain :: (Trigger.Result, FilePath, [Diagnostic]) -> IO ResponseReceived
+    textPlain (result, xs, _diagnostics) = case color of
       Left err -> respond $ responseLBS status400 [(hContentType, "text/plain")] (L.fromStrict err)
       Right c -> respond $ responseLBS status [(hContentType, "text/plain")] (encodeUtf8 . fromString $ strip xs)
         where
@@ -84,6 +91,12 @@ app trigger request respond = trigger >>= textPlain
             Trigger.Failure -> status500
             Trigger.Success -> status200
 
+json :: ToJSON a => a -> Response
+json value = responseLBS
+  status200
+  [("Content-Type", "application/json")]
+  (encode value)
+
 -- |
 -- Remove terminal sequences.
 stripAnsi :: String -> String

src/Language/Haskell/GhciWrapper.hs

@@ -22,6 +22,9 @@ import           Util (isWritableByOthers)
 import qualified ReadHandle
 import           ReadHandle (ReadHandle, toReadHandle)
 
+import GHC.Diagnostic (Diagnostic)
+import qualified GHC.Diagnostic as Diagnostic
+
 data Config = Config {
   configIgnoreDotGhci :: Bool
 , configWorkingDirectory :: Maybe FilePath
@@ -34,6 +37,7 @@ data Interpreter = Interpreter {
 , readHandle :: ReadHandle
 , process :: ProcessHandle
 , echo :: ByteString -> IO ()
+, formatDiagnostic :: Diagnostic -> ByteString
 }
 
 die :: String -> IO a
@@ -62,7 +66,8 @@ new startupFile Config{..} args_ = do
   checkDotGhci
   env <- sanitizeEnv <$> getEnvironment
   let
-    args = "-ghci-script" : startupFile : args_ ++ catMaybes [
+    -- args = "-fshow-loaded-modules" : "-ghci-script" : startupFile : args_ ++ catMaybes [
+    args = "-fdiagnostics-as-json" : "-ghci-script" : startupFile : args_ ++ catMaybes [
         if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing
       ]
 
@@ -86,6 +91,7 @@ new startupFile Config{..} args_ = do
     , hOut = stdoutReadEnd
     , process = processHandle
     , echo = configEcho
+    , formatDiagnostic = Diagnostic.format
     }
 
 
@@ -119,7 +125,7 @@ new startupFile Config{..} args_ = do
       hSetBuffering h LineBuffering
       hSetEncoding h utf8
 
-    printStartupMessages :: Interpreter -> IO String
+    printStartupMessages :: Interpreter -> IO (String, [Diagnostic])
     printStartupMessages interpreter = evalVerbose interpreter ""
 
     evalThrow :: Interpreter -> String -> IO ()
@@ -132,7 +138,7 @@ new startupFile Config{..} args_ = do
 close :: Interpreter -> IO ()
 close Interpreter{..} = do
   hClose hIn
-  ReadHandle.drain readHandle echo
+  ReadHandle.drain formatDiagnostic readHandle echo
   hClose hOut
   e <- waitForProcess process
   when (e /= ExitSuccess) $ do
@@ -144,14 +150,14 @@ putExpression Interpreter{hIn = stdin} e = do
   ByteString.hPut stdin ReadHandle.marker
   hFlush stdin
 
-getResult :: Interpreter -> IO String
-getResult Interpreter{..} = T.unpack . decodeUtf8 <$> ReadHandle.getResult readHandle echo
+getResult :: Interpreter -> IO (String, [Diagnostic])
+getResult Interpreter{..} = first (T.unpack . decodeUtf8) <$> ReadHandle.getResult formatDiagnostic readHandle echo
 
 silent :: ByteString -> IO ()
 silent _ = pass
 
 eval :: Interpreter -> String -> IO String
-eval ghci = evalVerbose ghci {echo = silent}
+eval ghci = fmap fst . evalVerbose ghci {echo = silent}
 
-evalVerbose :: Interpreter -> String -> IO String
+evalVerbose :: Interpreter -> String -> IO (String, [Diagnostic])
 evalVerbose ghci expr = putExpression ghci expr >> getResult ghci

src/ReadHandle.hs

@@ -6,6 +6,7 @@ module ReadHandle (
 , getResult
 , drain
 #ifdef TEST
+, breakAfterNewLine
 , newEmptyBuffer
 #endif
 ) where
@@ -16,7 +17,11 @@ import qualified Data.ByteString.Char8 as ByteString
 import           Data.IORef
 import           System.IO hiding (stdin, stdout, stderr, isEOF)
 
+import           Data.Aeson
+
 import           Data.ByteString (dropEnd)
+import           Data.ByteString.Lazy (fromStrict)
+import           Data.IORef
 
 -- | Truly random marker, used to separate expressions.
 --
@@ -34,9 +39,9 @@ data ReadHandle = ReadHandle {
 , buffer :: IORef Buffer
 }
 
-drain :: ReadHandle -> (ByteString -> IO ()) -> IO ()
-drain h echo = while (not <$> isEOF h) $ do
-  _ <- getResult h echo
+drain :: FromJSON a => (a -> ByteString) -> ReadHandle -> (ByteString -> IO ()) -> IO ()
+drain formatDiagnostic h echo = while (not <$> isEOF h) $ do
+  _ <- getResult formatDiagnostic h echo
   pass
 
 isEOF :: ReadHandle -> IO Bool
@@ -73,15 +78,55 @@ toReadHandle h n = do
 newEmptyBuffer :: IO (IORef Buffer)
 newEmptyBuffer = newIORef BufferEmpty
 
-getResult :: ReadHandle -> (ByteString -> IO ()) -> IO ByteString
-getResult h echo = mconcat <$> go
-  where
-    go :: IO [ByteString]
-    go = nextChunk h >>= \ case
-      Chunk chunk -> echo chunk >> (chunk :) <$> go
+getResult :: FromJSON a => (a -> ByteString) -> ReadHandle -> (ByteString -> IO ()) -> IO (ByteString, [a])
+getResult formatDiagnostic h echo = do
+  ref <- newIORef []
+
+  let
+    startOfLine :: IO [ByteString]
+    startOfLine = nextChunk h >>= p_startOfLine
+
+    p_startOfLine :: Chunk -> IO [ByteString]
+    p_startOfLine = \ case
+      Chunk chunk | ByteString.isPrefixOf "{" chunk -> p_goJson chunk
+      c -> p_notStartOfLine c
+
+    notStartOfLine :: IO [ByteString]
+    notStartOfLine = nextChunk h >>= p_notStartOfLine
+
+    p_notStartOfLine :: Chunk -> IO [ByteString]
+    p_notStartOfLine = \ case
+      Chunk chunk -> case breakAfterNewLine chunk of
+        Nothing -> echo chunk >> (chunk :) <$> notStartOfLine
+        Just (c, "") -> echo c >> (c :) <$> startOfLine
+        Just (c, xs) -> echo c >> (c :) <$> p_startOfLine (Chunk xs)
+
+      Marker -> return []
+      EOF -> return []
+
+    goJson :: ByteString -> IO [ByteString]
+    goJson acc = nextChunk h >>= \ case
+      Chunk chunk -> p_goJson (acc <> chunk)
       Marker -> return []
       EOF -> return []
 
+    p_goJson :: ByteString -> IO [ByteString]
+    p_goJson chunk = case breakAfterNewLine chunk of
+      Nothing -> goJson chunk
+      Just (pre, suf) -> case decode (fromStrict $ ByteString.strip pre) of
+        Nothing -> echo pre >> (pre :) <$> p_startOfLine (Chunk suf)
+        Just diagnostic -> do
+          let d = formatDiagnostic diagnostic
+          modifyIORef' ref (diagnostic :)
+          echo d >> (d :) <$> p_startOfLine (Chunk suf)
+
+  (,) <$> (mconcat <$> startOfLine) <*> readIORef ref
+
+breakAfterNewLine :: ByteString -> Maybe (ByteString, ByteString)
+breakAfterNewLine input = case ByteString.elemIndex '\n' input of
+  Just n -> Just (ByteString.splitAt (n + 1) input)
+  Nothing -> Nothing
+
 data Chunk = Chunk ByteString | Marker | EOF
 
 nextChunk :: ReadHandle -> IO Chunk

src/Run.hs

@@ -27,6 +27,8 @@ import           Pager (pager)
 import           Util
 import           Config
 
+import           GHC.Diagnostic
+
 waitForever :: IO ()
 waitForever = forever $ threadDelay 10000000
 
@@ -85,7 +87,7 @@ run args = do
 defaultRunArgs :: IO RunArgs
 defaultRunArgs = do
   queue <- newQueue
-  lastOutput <- newMVar (Trigger.Success, "")
+  lastOutput <- newMVar (Trigger.Success, "", [])
   return RunArgs {
     ignoreConfig = False
   , dir = ""
@@ -100,7 +102,7 @@ data RunArgs = RunArgs {
   ignoreConfig :: Bool
 , dir :: FilePath
 , args :: [String]
-, lastOutput :: MVar (Result, String)
+, lastOutput :: MVar (Result, String, [Diagnostic])
 , queue :: EventQueue
 , sessionConfig  :: Session.Config
 , withSession :: forall r. Session.Config -> [String] -> (Session.Session -> IO r) -> IO r
@@ -119,16 +121,16 @@ runWith RunArgs {..} = do
     addCleanupAction :: IO () -> IO ()
     addCleanupAction cleanupAction = atomicModifyIORef' cleanup $ \ action -> (action >> cleanupAction, ())
 
-    saveOutput :: IO (Trigger.Result, String) -> IO ()
+    saveOutput :: IO (Trigger.Result, String, [Diagnostic]) -> IO ()
     saveOutput action = do
       runCleanupAction
       result <- modifyMVar lastOutput $ \ _ -> (id &&& id) <$> action
       case result of
-        (HookFailed, _output) -> pass
-        (Failure, output) -> config.senseiHooksOnFailure >>= \ case
+        (HookFailed, _output, _diagnostics) -> pass
+        (Failure, output, _diagnostics) -> config.senseiHooksOnFailure >>= \ case
           HookSuccess -> pager output >>= addCleanupAction
           HookFailure message -> hPutStrLn stderr message
-        (Success, _output) -> config.senseiHooksOnSuccess >>= \ case
+        (Success, _output, _diagnostics) -> config.senseiHooksOnSuccess >>= \ case
           HookSuccess -> pass
           HookFailure message -> hPutStrLn stderr message
 
@@ -170,3 +172,9 @@ defaultSessionConfig = Session.Config {
 , configWorkingDirectory = Nothing
 , configEcho = \ string -> ByteString.putStr string >> hFlush stdout
 }
+
+-- -fno-show-error-context
+-- -fno-diagnostics-show-caret
+-- -ferror-spans -fdiagnostics-color=never
+
+-- And check ~/.ghci