Add support for GHC JSON diagnostics

package.yaml

@@ -45,6 +45,7 @@ dependencies:
   - yaml
   - casing
   - temporary
+  - ghc
 
 ghc-options: -Wall -threaded
 

src/GHC/Diagnostic.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE DeriveAnyClass #-}
+module GHC.Diagnostic where
+
+import Prelude hiding (span)
+import Imports hiding (empty)
+import GHC.Generics
+import Data.Aeson (ToJSON(..), FromJSON(..), decode)
+import Data.ByteString.Lazy (fromStrict)
+
+import           GHC.Types.SrcLoc
+import           GHC.Types.Error hiding (Severity, Diagnostic)
+import           GHC.Utils.Error hiding (Severity, Diagnostic)
+import qualified GHC.Utils.Error as GHC
+import           GHC.Utils.Outputable
+
+data Diagnostic = Diagnostic {
+  version :: String
+, ghcVersion :: String
+, span :: Maybe 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)
+
+parse :: ByteString -> Maybe Diagnostic
+parse = decode . fromStrict
+
+toSrcSpan :: Maybe Span -> SrcSpan
+toSrcSpan = \ case
+  Nothing -> UnhelpfulSpan UnhelpfulNoLocationInfo
+  Just span -> mkSrcSpan (loc span.start) (loc span.end)
+    where
+      loc l = mkSrcLoc (fromString span.file) l.line l.column
+
+format :: Diagnostic -> ByteString
+format = diagnosticToSDoc >>> showSDocUnsafe >>> encodeUtf8
+
+
+diagnosticToSDoc :: Diagnostic -> SDoc
+diagnosticToSDoc diagnostic = result $+$ blankLine $+$ blankLine
+  where
+    result :: SDoc
+    result = mkLocMessageWarningGroups printWarningGroups msg_class span formatted
+
+    printWarningGroups :: Bool
+    -- printWarningGroups = True
+    printWarningGroups = False
+
+    formatted :: SDoc
+    -- formatted = updSDocContext (\_ -> ctx) messageWithHints
+    formatted = messageWithHints
+
+    msg_class :: MessageClass
+    msg_class = MCDiagnostic severity reason code
+
+    reason :: ResolvedDiagnosticReason
+    -- reason = undefined -- msg.errMsgReason
+    reason = ResolvedDiagnosticReason ErrorWithoutFlag
+
+    -- style :: PprStyle
+    -- style = defaultErrStyle
+
+    -- opts :: DiagOpts
+    -- opts = emptyDiagOpts -- FIXME
+
+    -- ctx :: SDocContext
+    -- ctx = (diag_ppr_ctx opts) { sdocStyle = style }
+
+    span :: SrcSpan
+    span = toSrcSpan diagnostic.span
+
+    severity :: GHC.Severity
+    severity = case diagnostic.severity of
+      Warning -> SevWarning
+      Error -> SevError
+
+
+    code :: Maybe DiagnosticCode
+    code = DiagnosticCode "GHC" . fromIntegral <$> diagnostic.code
+
+    hints :: [SDoc]
+    hints = map verbose diagnostic.hints
+
+    message :: SDoc
+    message = bulleted $ map verbose diagnostic.message
+
+    messageWithHints :: SDoc
+    messageWithHints = case hints of
+      []  -> message
+      [h] -> message $$ hang (text "Suggested fix:") 2 h
+      hs  -> message $$ hang (text "Suggested fixes:") 2 (bulleted hs)
+
+bulleted :: [SDoc] -> SDoc
+bulleted = formatBulleted . mkDecorated
+
+verbose :: String -> SDoc
+verbose = foldr ($+$) empty . map text . lines
+
+-- FIXME: check performance impact

src/HTTP.hs

@@ -11,9 +11,10 @@ module HTTP (
 #endif
 ) where
 
-import           Imports hiding (encodeUtf8)
+import           Imports hiding (strip, encodeUtf8)
 
 import           System.Directory
+import           Data.Aeson (ToJSON(..), encode)
 import qualified Data.ByteString.Lazy as L
 import           Data.Text.Lazy.Encoding (encodeUtf8)
 import           Network.Wai
@@ -22,6 +23,7 @@ import           Network.Wai.Handler.Warp (runSettingsSocket, defaultSettings)
 import           Network.Socket
 
 import qualified Trigger
+import           GHC.Diagnostic
 
 socketName :: FilePath -> String
 socketName dir = dir </> ".sensei.sock"
@@ -35,8 +37,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 +61,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 +75,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 +90,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/Imports.hs

@@ -11,7 +11,7 @@ import           Data.Functor as Imports ((<&>))
 import           Data.Bifunctor as Imports
 import           Data.Char as Imports
 import           Data.Either as Imports
-import           Data.List as Imports
+import           Data.List as Imports hiding (span)
 import           Data.Maybe as Imports
 import           Data.String as Imports
 import           Data.ByteString.Char8 as Imports (ByteString, pack, unpack)
@@ -26,6 +26,10 @@ import           Control.Monad.IO.Class as Imports
 import           System.IO (Handle)
 import           GHC.IO.Handle.Internals (wantReadableHandle_)
 
+import           Data.Version as Imports (Version(..), showVersion, makeVersion)
+import qualified Data.Version as Version
+import           Text.ParserCombinators.ReadP
+
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 
@@ -55,3 +59,11 @@ encodeUtf8 = T.encodeUtf8 . T.pack
 
 decodeUtf8 :: ByteString -> String
 decodeUtf8 = T.unpack . T.decodeUtf8
+
+strip :: String -> String
+strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+
+parseVersion :: String -> Maybe Version
+parseVersion xs = case [v | (v, "") <- readP_to_S Version.parseVersion xs] of
+  [v] -> Just v
+  _ -> Nothing