From 87646c06b820fa48a0c77c82004396757fd0b2f4 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sat, 25 Jan 2025 21:15:26 +0700 Subject: [PATCH] Add `/quick-fix` endpoint --- sensei.cabal | 4 ++ src/GHC/Diagnostic.hs | 136 +++++++++++-------------------------- src/GHC/Diagnostic/Type.hs | 106 +++++++++++++++++++++++++++++ src/HTTP.hs | 52 +++++--------- src/Util.hs | 21 ++++++ test/GHC/DiagnosticSpec.hs | 27 ++++---- test/HTTPSpec.hs | 8 --- test/UtilSpec.hs | 8 +++ 8 files changed, 208 insertions(+), 154 deletions(-) create mode 100644 src/GHC/Diagnostic/Type.hs diff --git a/sensei.cabal b/sensei.cabal index 239582cd..2b04a12f 100644 --- a/sensei.cabal +++ b/sensei.cabal @@ -26,6 +26,7 @@ executable seito Config EventQueue GHC.Diagnostic + GHC.Diagnostic.Type HTTP Imports Input @@ -87,6 +88,7 @@ executable sensei Config EventQueue GHC.Diagnostic + GHC.Diagnostic.Type HTTP Imports Input @@ -148,6 +150,7 @@ executable sensei-web Config EventQueue GHC.Diagnostic + GHC.Diagnostic.Type HTTP Imports Input @@ -210,6 +213,7 @@ test-suite spec Config EventQueue GHC.Diagnostic + GHC.Diagnostic.Type HTTP Imports Input diff --git a/src/GHC/Diagnostic.hs b/src/GHC/Diagnostic.hs index af91e190..3b4af968 100644 --- a/src/GHC/Diagnostic.hs +++ b/src/GHC/Diagnostic.hs @@ -1,106 +1,46 @@ -{-# LANGUAGE DeriveAnyClass #-} module GHC.Diagnostic ( - Diagnostic(..) -, Span(..) -, Location(..) -, Severity(..) -, parse -, format + module Diagnostic +, Action(..) +, analyze +, apply ) where -import Prelude hiding ((<>), span, unlines) -import Imports hiding (empty, unlines) -import GHC.Generics (Generic) -import Data.Aeson (ToJSON(..), FromJSON(..), decode) -import Data.ByteString.Lazy (fromStrict) -import Text.PrettyPrint +import Imports -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) +import System.IO +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString as B +import Data.ByteString.Builder (hPutBuilder) -data Span = Span { - file :: FilePath -, start :: Location -, end :: Location -} deriving (Eq, Show, Generic, ToJSON, FromJSON) +import GHC.Diagnostic.Type as Diagnostic -data Location = Location { - line :: Int -, column :: Int -} deriving (Eq, Show, Generic, ToJSON, FromJSON) +data Action = AddExtension FilePath Text + deriving (Eq, Show) -data Severity = Warning | Error - deriving (Eq, Show, Generic, ToJSON, FromJSON) - -parse :: ByteString -> Maybe Diagnostic -parse = fmap removeGhciSpecificHints . decode . fromStrict - -format :: Diagnostic -> ByteString -format diagnostic = encodeUtf8 . render $ unlines [ - hang header 4 messageWithHints - , "" - , "" - ] - where - header :: Doc - header = span <> colon <+> severity <> colon <+> code - - span :: Doc - span = case diagnostic.span of - Nothing -> "" - Just loc -> text loc.file <> colon <> int loc.start.line <> colon <> int loc.start.column - - severity :: Doc - severity = case diagnostic.severity of - Warning -> "warning" - Error -> "error" - - code :: Doc - code = case diagnostic.code of - Nothing -> empty - Just c -> brackets $ "GHC-" <> int c - - message :: Doc - message = bulleted $ map verbatim diagnostic.message - - hints :: [Doc] - hints = map verbatim diagnostic.hints - - messageWithHints :: Doc - messageWithHints = case hints of - [] -> message - [h] -> message $$ hang (text "Suggested fix:") 2 h - hs -> message $$ hang (text "Suggested fixes:") 2 (bulleted hs) - - bulleted :: [Doc] -> Doc - bulleted = \ case - [] -> empty - [doc] -> doc - docs -> vcat $ map (char '•' <+>) docs - - verbatim :: String -> Doc - verbatim = unlines . map text . lines - - unlines :: [Doc] -> Doc - unlines = foldr ($+$) empty - -removeGhciSpecificHints :: Diagnostic -> Diagnostic -removeGhciSpecificHints diagnostic = diagnostic { hints = map processHint diagnostic.hints } +analyze :: Diagnostic -> Maybe Action +analyze diagnostic = listToMaybe $ mapMaybe analyzeHint diagnostic.hints where - isSetLanguageExtension :: String -> Bool - isSetLanguageExtension = isPrefixOf " :set -X" - - processHint :: String -> String - processHint input = case lines input of - [hint, "You may enable this language extension in GHCi with:", ghciHint] - | isSetLanguageExtension ghciHint -> hint - hint : "You may enable these language extensions in GHCi with:" : ghciHints - | all isSetLanguageExtension ghciHints -> hint - _ -> input + analyzeHint :: String -> Maybe Action + analyzeHint (T.pack -> hint) = + perhapsYouIntendedToUse + <|> enableAnyOfTheFollowingExtensions + where + perhapsYouIntendedToUse :: Maybe Action + perhapsYouIntendedToUse = do + AddExtension . (.file) <$> diagnostic.span <*> T.stripPrefix "Perhaps you intended to use " hint + + enableAnyOfTheFollowingExtensions :: Maybe Action + enableAnyOfTheFollowingExtensions = do + file <- (.file) <$> diagnostic.span + T.stripPrefix "Enable any of the following extensions: " hint + >>= listToMaybe . reverse . map (AddExtension file) . T.splitOn ", " + +apply :: Action -> IO () +apply = \ case + AddExtension file name -> do + old <- B.readFile file + withFile file WriteMode $ \ h -> do + hPutBuilder h $ "{-# LANGUAGE " <> T.encodeUtf8Builder name <> " #-}\n" + B.hPutStr h old diff --git a/src/GHC/Diagnostic/Type.hs b/src/GHC/Diagnostic/Type.hs new file mode 100644 index 00000000..100ac5de --- /dev/null +++ b/src/GHC/Diagnostic/Type.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DeriveAnyClass #-} +module GHC.Diagnostic.Type ( + Diagnostic(..) +, Span(..) +, Location(..) +, Severity(..) +, parse +, format +) where + +import Prelude hiding ((<>), span, unlines) +import Imports hiding (empty, unlines) +import GHC.Generics (Generic) +import Data.Aeson (ToJSON(..), FromJSON(..), decode) +import Data.ByteString.Lazy (fromStrict) +import Text.PrettyPrint + +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 = fmap removeGhciSpecificHints . decode . fromStrict + +format :: Diagnostic -> ByteString +format diagnostic = encodeUtf8 . render $ unlines [ + hang header 4 messageWithHints + , "" + , "" + ] + where + header :: Doc + header = span <> colon <+> severity <> colon <+> code + + span :: Doc + span = case diagnostic.span of + Nothing -> "" + Just loc -> text loc.file <> colon <> int loc.start.line <> colon <> int loc.start.column + + severity :: Doc + severity = case diagnostic.severity of + Warning -> "warning" + Error -> "error" + + code :: Doc + code = case diagnostic.code of + Nothing -> empty + Just c -> brackets $ "GHC-" <> int c + + message :: Doc + message = bulleted $ map verbatim diagnostic.message + + hints :: [Doc] + hints = map verbatim diagnostic.hints + + messageWithHints :: Doc + messageWithHints = case hints of + [] -> message + [h] -> message $$ hang (text "Suggested fix:") 2 h + hs -> message $$ hang (text "Suggested fixes:") 2 (bulleted hs) + + bulleted :: [Doc] -> Doc + bulleted = \ case + [] -> empty + [doc] -> doc + docs -> vcat $ map (char '•' <+>) docs + + verbatim :: String -> Doc + verbatim = unlines . map text . lines + + unlines :: [Doc] -> Doc + unlines = foldr ($+$) empty + +removeGhciSpecificHints :: Diagnostic -> Diagnostic +removeGhciSpecificHints diagnostic = diagnostic { hints = map processHint diagnostic.hints } + where + isSetLanguageExtension :: String -> Bool + isSetLanguageExtension = isPrefixOf " :set -X" + + processHint :: String -> String + processHint input = case lines input of + [hint, "You may enable this language extension in GHCi with:", ghciHint] + | isSetLanguageExtension ghciHint -> hint + hint : "You may enable these language extensions in GHCi with:" : ghciHints + | all isSetLanguageExtension ghciHints -> hint + _ -> input diff --git a/src/HTTP.hs b/src/HTTP.hs index 75c9d204..476121c8 100644 --- a/src/HTTP.hs +++ b/src/HTTP.hs @@ -7,16 +7,14 @@ module HTTP ( #ifdef TEST , app -, stripAnsi #endif ) where import Imports hiding (strip, encodeUtf8) import System.Directory -import Data.Aeson (ToJSON(..), encode) +import Data.Aeson import Data.ByteString.Builder -import Data.Text.Lazy.Encoding (encodeUtf8) import Network.Wai import Network.HTTP.Types import qualified Network.HTTP.Types.Status as Status @@ -24,6 +22,7 @@ import Network.HTTP.Media import Network.Wai.Handler.Warp (runSettingsSocket, defaultSettings) import Network.Socket +import Util import qualified Trigger import GHC.Diagnostic @@ -73,6 +72,12 @@ app getLastResult request respond = case pathInfo request of (_, _, diagnostics) <- getLastResult respond $ json diagnostics + ["quick-fix"] -> requireMethod "POST" $ do + getLastResult >>= \ case + (_, _, (analyze -> Just action) : _) -> apply action + _ -> pass + respond $ jsonResponse Status.ok200 "{}" + _ -> do respond $ genericStatus Status.notFound404 request @@ -86,8 +91,8 @@ app getLastResult request respond = case pathInfo request of textPlain :: (Trigger.Result, FilePath, [Diagnostic]) -> IO ResponseReceived textPlain (result, xs, _diagnostics) = case color of - Left err -> respond $ responseBuilder Status.badRequest400 [(hContentType, "text/plain")] err - Right c -> respond $ responseLBS status [(hContentType, "text/plain")] (encodeUtf8 . fromString $ strip xs) + Left err -> respond $ textResponse Status.badRequest400 err + Right c -> respond . textResponse status . stringUtf8 $ strip xs where strip :: String -> String strip @@ -106,7 +111,7 @@ app getLastResult request respond = case pathInfo request of _ -> respond $ genericRfc7807Response Status.methodNotAllowed405 json :: ToJSON a => a -> Response - json = responseLBS Status.ok200 [(hContentType, "application/json")] . encode + json = jsonResponse Status.ok200 . fromEncoding . toEncoding genericStatus :: Status -> Request -> Response genericStatus status@(Status number message) request = fromMaybe text $ mapAcceptMedia [ @@ -115,42 +120,19 @@ genericStatus status@(Status number message) request = fromMaybe text $ mapAccep ] =<< lookup "Accept" request.requestHeaders where text :: Response - text = responseBuilder - status - [(hContentType, "text/plain")] - body - where - body :: Builder - body = intDec number <> " " <> byteString message + text = textResponse status $ intDec number <> " " <> byteString message json :: Response json = genericRfc7807Response status genericRfc7807Response :: Status -> Response -genericRfc7807Response status@(Status number message) = responseBuilder - status - [(hContentType, "application/json")] - body +genericRfc7807Response status@(Status number message) = jsonResponse status body where body :: Builder body = "{\"title\":\"" <> byteString message <> "\",\"status\":" <> intDec number <> "}" --- | --- Remove terminal sequences. -stripAnsi :: String -> String -stripAnsi = go - where - go input = case input of - '\ESC' : '[' : (dropNumericParameters -> c : xs) | isCommand c -> go xs - '\ESC' : '[' : '?' : (dropNumericParameters -> c : xs) | isCommand c -> go xs - x : xs -> x : go xs - [] -> [] - - dropNumericParameters :: FilePath -> FilePath - dropNumericParameters = dropWhile (`elem` ("0123456789;" :: [Char])) - - isCommand :: Char -> Bool - isCommand = (`elem` commands) +jsonResponse :: Status -> Builder -> Response +jsonResponse status body = responseBuilder status [(hContentType, "application/json")] body - commands :: FilePath - commands = ['A'..'Z'] <> ['a'..'z'] +textResponse :: Status -> Builder -> Response +textResponse status = responseBuilder status [(hContentType, "text/plain")] diff --git a/src/Util.hs b/src/Util.hs index 7cf7e306..257730ff 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -3,6 +3,7 @@ module Util ( Color(..) , withColor , withInfoColor +, stripAnsi , isBoring , filterGitIgnoredFiles , normalizeTypeSignatures @@ -32,6 +33,26 @@ withColor c string = set <> string <> reset set = setSGRCode [SetColor Foreground Dull c] reset = setSGRCode [] +-- | +-- Remove terminal sequences. +stripAnsi :: String -> String +stripAnsi = go + where + go input = case input of + '\ESC' : '[' : (dropNumericParameters -> c : xs) | isCommand c -> go xs + '\ESC' : '[' : '?' : (dropNumericParameters -> c : xs) | isCommand c -> go xs + x : xs -> x : go xs + [] -> [] + + dropNumericParameters :: FilePath -> FilePath + dropNumericParameters = dropWhile (`elem` ("0123456789;" :: [Char])) + + isCommand :: Char -> Bool + isCommand = (`elem` commands) + + commands :: FilePath + commands = ['A'..'Z'] <> ['a'..'z'] + isBoring :: FilePath -> Bool isBoring p = ".git" `elem` dirs || "dist" `elem` dirs || isEmacsAutoSave p where diff --git a/test/GHC/DiagnosticSpec.hs b/test/GHC/DiagnosticSpec.hs index 2e160966..03dcb482 100644 --- a/test/GHC/DiagnosticSpec.hs +++ b/test/GHC/DiagnosticSpec.hs @@ -10,14 +10,15 @@ import Language.Haskell.GhciWrapper (lookupGhc) import GHC.Diagnostic -test :: HasCallStack => FilePath -> Spec -test name = it name $ do +test :: HasCallStack => FilePath -> Maybe Action -> Spec +test name edit = it name $ do err <- translate <$> ghc ["-fno-diagnostics-show-caret"] json <- encodeUtf8 <$> ghc ["-fdiagnostics-as-json", "--interactive", "-ignore-dot-ghci"] ensureFile (dir "err.out") (encodeUtf8 err) ensureFile (dir "err.json") json Just diagnostic <- return $ parse json decodeUtf8 (format diagnostic) `shouldBe` err + analyze diagnostic `shouldBe` edit where dir :: FilePath dir = "test" "assets" name @@ -38,20 +39,20 @@ test name = it name $ do '’' -> '\'' c -> c -ftest :: HasCallStack => FilePath -> Spec -ftest = focus . test +ftest :: HasCallStack => FilePath -> Maybe Action -> Spec +ftest name = focus . test name -_ignore :: HasCallStack => FilePath -> Spec +_ignore :: HasCallStack => FilePath -> Maybe Action -> Spec _ignore = ftest spec :: Spec spec = do describe "format" $ do - test "variable-not-in-scope" - test "variable-not-in-scope-perhaps-use" - test "use-BlockArguments" - test "use-TemplateHaskellQuotes" - test "non-existing" - test "parse-error" - test "lex-error" - test "multiple-error-messages" + test "variable-not-in-scope" Nothing + test "variable-not-in-scope-perhaps-use" Nothing + test "use-BlockArguments" (Just $ AddExtension "test/assets/use-BlockArguments/Foo.hs" "BlockArguments") + test "use-TemplateHaskellQuotes" (Just $ AddExtension "test/assets/use-TemplateHaskellQuotes/Foo.hs" "TemplateHaskellQuotes") + test "non-existing" Nothing + test "parse-error" Nothing + test "lex-error" Nothing + test "multiple-error-messages" Nothing diff --git a/test/HTTPSpec.hs b/test/HTTPSpec.hs index e31dd9e8..1cd0b36c 100644 --- a/test/HTTPSpec.hs +++ b/test/HTTPSpec.hs @@ -5,7 +5,6 @@ import Helper import Network.Wai (Application) import Test.Hspec.Wai -import qualified System.Console.ANSI as Ansi import HTTP import qualified Trigger @@ -71,10 +70,3 @@ spec = do request "GET" "/foo" [("Accept", "application/json")] "" `shouldRespondWith` 404 { matchBody = "{\"title\":\"Not Found\",\"status\":404}" } - - describe "stripAnsi" $ do - it "removes ANSI color sequences" $ do - stripAnsi ("some " <> withColor Green "colorized" <> " text") `shouldBe` "some colorized text" - - it "removes DEC private mode sequences" $ do - stripAnsi (Ansi.hideCursorCode <> "some text" <> Ansi.showCursorCode) `shouldBe` "some text" diff --git a/test/UtilSpec.hs b/test/UtilSpec.hs index 8e3f10e6..f11da42d 100644 --- a/test/UtilSpec.hs +++ b/test/UtilSpec.hs @@ -2,6 +2,7 @@ module UtilSpec (spec) where import Helper +import qualified System.Console.ANSI as Ansi import System.Posix.Files import Util @@ -18,6 +19,13 @@ chmod mode file = callProcess "chmod" [mode, file] spec :: Spec spec = do + describe "stripAnsi" $ do + it "removes ANSI color sequences" $ do + stripAnsi ("some " <> withColor Green "colorized" <> " text") `shouldBe` "some colorized text" + + it "removes DEC private mode sequences" $ do + stripAnsi (Ansi.hideCursorCode <> "some text" <> Ansi.showCursorCode) `shouldBe` "some text" + describe "isBoring" $ do it "ignores files in .git/" $ do isBoring "/foo/bar/.git/baz/foo.txt" `shouldBe` True