Add /quick-fix endpoint

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 -> "<no location info>"
-      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

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 -> "<no location info>"
+      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

src/HTTP.hs

@@ -7,23 +7,22 @@ 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
 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")]