hls-hlint-plugin 2.0.0.1 → 2.1.0.0

raw patch · 3 files changed

+201/−177 lines, 3 filesdep +mtldep +row-typesdep ~ghcidedep ~hlintdep ~hls-plugin-apiPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, row-types

Dependency ranges changed: ghcide, hlint, hls-plugin-api, hls-test-utils

API changes (from Hackage documentation)

Files

• hls-hlint-plugin.cabal +7/−9
• src/Ide/Plugin/Hlint.hs +128/−142
• test/Main.hs +66/−26

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:          hls-hlint-plugin-version:            2.0.0.1+version:       2.1.0.0 synopsis:      Hlint integration plugin with Haskell Language Server description:   Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -30,8 +30,6 @@   manual:      True  library-  if impl(ghc >= 9.5)-    buildable: False   exposed-modules:    Ide.Plugin.Hlint   hs-source-dirs:     src   build-depends:@@ -47,12 +45,13 @@     , extra     , filepath     , ghc-exactprint        >=0.6.3.4-    , ghcide                == 2.0.0.1+    , ghcide                == 2.1.0.0     , hashable-    , hlint                 < 3.6-    , hls-plugin-api        == 2.0.0.1+    , hlint                 < 3.7+    , hls-plugin-api        == 2.1.0.0     , lens     , lsp+    , mtl     , refact     , regex-tdfa     , stm@@ -78,8 +77,6 @@     TypeOperators  test-suite tests-  if impl(ghc >= 9.5)-    buildable: False   type:             exitcode-stdio-1.0   default-language: Haskell2010   hs-source-dirs:   test@@ -92,7 +89,8 @@     , filepath     , hls-hlint-plugin     , hls-plugin-api-    , hls-test-utils      == 2.0.0.1+    , hls-test-utils      == 2.1.0.0     , lens     , lsp-types+    , row-types     , text

@@ -1,23 +1,24 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE LambdaCase            #-}-{-# LANGUAGE MultiWayIf            #-}-{-# LANGUAGE NamedFieldPuns        #-}-{-# LANGUAGE OverloadedLabels      #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE PackageImports        #-}-{-# LANGUAGE PatternSynonyms       #-}-{-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE StrictData            #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE ViewPatterns          #-}-+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE DeriveAnyClass            #-}+{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE DuplicateRecordFields     #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE LambdaCase                #-}+{-# LANGUAGE MultiWayIf                #-}+{-# LANGUAGE NamedFieldPuns            #-}+{-# LANGUAGE OverloadedLabels          #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE PackageImports            #-}+{-# LANGUAGE PatternSynonyms           #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE StrictData                #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE TypeApplications          #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE ViewPatterns              #-} {-# OPTIONS_GHC -Wno-orphans   #-}  -- On 9.4 we get a new redundant constraint warning, but deleting the@@ -40,16 +41,20 @@ import           Control.Concurrent.STM import           Control.DeepSeq import           Control.Exception-import           Control.Lens                                       ((^.))+import           Control.Lens                                       ((?~), (^.)) import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Except+import           Control.Monad.Error.Class                          (MonadError (throwError))+import           Control.Monad.IO.Class                             (MonadIO (liftIO))+import           Control.Monad.Trans.Class                          (MonadTrans (lift))+import           Control.Monad.Trans.Except                         (ExceptT (..),+                                                                     runExceptT) import           Data.Aeson.Types                                   (FromJSON (..),                                                                      ToJSON (..),                                                                      Value (..)) import qualified Data.ByteString                                    as BS import           Data.Hashable import qualified Data.HashMap.Strict                                as Map+import qualified Data.Map                                           as M import           Data.Maybe import qualified Data.Text                                          as T import qualified Data.Text.Encoding                                 as T@@ -57,6 +62,7 @@ import           Development.IDE                                    hiding                                                                     (Error,                                                                      getExtensions)+import           Development.IDE.Core.Compile                       (sourceParser) import           Development.IDE.Core.Rules                         (defineNoFile,                                                                      getParsedModuleWithComments) import           Development.IDE.Core.Shake                         (getDiagnostics)@@ -111,24 +117,22 @@ import           Language.Haskell.GhclibParserEx.Fixity             as GhclibParserEx (applyFixities) import qualified Refact.Fixity                                      as Refact #endif- import           Ide.Plugin.Config                                  hiding                                                                     (Config)+import           Ide.Plugin.Error import           Ide.Plugin.Properties+import           Ide.Plugin.Resolve import           Ide.PluginUtils import           Ide.Types                                          hiding                                                                     (Config) import           Language.Haskell.HLint                             as Hlint hiding                                                                              (Error)-import           Language.LSP.Server                                (ProgressCancellable (Cancellable),-                                                                     sendRequest,-                                                                     withIndefiniteProgress)-import           Language.LSP.Types                                 hiding-                                                                    (SemanticTokenAbsolute (length, line),-                                                                     SemanticTokenRelative (length),-                                                                     SemanticTokensEdit (_start))-import qualified Language.LSP.Types                                 as LSP-import qualified Language.LSP.Types.Lens                            as LSP+import qualified Language.LSP.Protocol.Lens                         as LSP+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types                        hiding+                                                                    (Null)+import qualified Language.LSP.Protocol.Types                        as LSP+import           Language.LSP.Server                                (getVersionedTextDoc)  import qualified Development.IDE.Core.Shake                         as Shake import           Development.IDE.Spans.Pragmas                      (LineSplitTextEdits (LineSplitTextEdits),@@ -144,6 +148,7 @@ import           System.Environment                                 (setEnv,                                                                      unsetEnv) #endif+import           Development.IDE.Core.PluginUtils                   as PluginUtils import           Text.Regex.TDFA.Text                               () -- --------------------------------------------------------------------- @@ -153,7 +158,7 @@   | LogGeneratedIdeas NormalizedFilePath [[Refact.Refactoring Refact.SrcSpan]]   | LogGetIdeas NormalizedFilePath   | LogUsingExtensions NormalizedFilePath [String] -- Extension is only imported conditionally, so we just stringify them-  deriving Show+  | forall a. (Pretty a) => LogResolve a  instance Pretty Log where   pretty = \case@@ -162,6 +167,7 @@     LogGeneratedIdeas fp ideas -> "Generated hlint ideas for for" <+> viaShow fp <> ":" <+> viaShow ideas     LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <+> pretty exts     LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp+    LogResolve msg -> pretty msg  #ifdef HLINT_ON_GHC_LIB -- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib@@ -186,13 +192,13 @@ #endif  descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState-descriptor recorder plId = (defaultPluginDescriptor plId)+descriptor recorder plId =+  let resolveRecorder = cmapWithPrio LogResolve recorder+      (pluginCommands, pluginHandlers) = mkCodeActionWithResolveAndCommand resolveRecorder plId codeActionProvider (resolveProvider recorder)+  in (defaultPluginDescriptor plId)   { pluginRules = rules recorder plId-  , pluginCommands =-      [ PluginCommand "applyOne" "Apply a single hint" (applyOneCmd recorder)-      , PluginCommand "applyAll" "Apply all hints to the file" (applyAllCmd recorder)-      ]-  , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider+  , pluginCommands = pluginCommands+  , pluginHandlers = pluginHandlers   , pluginConfigDescriptor = defaultConfigDescriptor       { configHasDiagnostics = True       , configCustomConfig = mkCustomConfig properties@@ -243,13 +249,15 @@       ideaToDiagnostic idea =         LSP.Diagnostic {             _range    = srcSpanToRange $ ideaSpan idea-          , _severity = Just LSP.DsInfo+          , _severity = Just LSP.DiagnosticSeverity_Information           -- we are encoding the fact that idea has refactorings in diagnostic code           , _code     = Just (InR $ T.pack $ codePre ++ ideaHint idea)           , _source   = Just "hlint"           , _message  = idea2Message idea           , _relatedInformation = Nothing           , _tags     = Nothing+          , _codeDescription = Nothing+          , _data_ = Nothing         }         where codePre = if null $ ideaRefactoring idea then "" else "refact:" @@ -267,12 +275,14 @@       parseErrorToDiagnostic (Hlint.ParseError l msg contents) =         LSP.Diagnostic {             _range    = srcSpanToRange l-          , _severity = Just LSP.DsInfo-          , _code     = Just (InR "parser")+          , _severity = Just LSP.DiagnosticSeverity_Information+          , _code     = Just (InR sourceParser)           , _source   = Just "hlint"           , _message  = T.unlines [T.pack msg,T.pack contents]           , _relatedInformation = Nothing           , _tags     = Nothing+          , _codeDescription = Nothing+          , _data_ = Nothing         }        -- This one is defined in Development.IDE.GHC.Error but here@@ -390,25 +400,16 @@   Config     <$> usePropertyAction #flags pId properties -runHlintAction- :: (Eq k, Hashable k, Show k, Show (RuleResult k), Typeable k, Typeable (RuleResult k), NFData k, NFData (RuleResult k))- => IdeState- -> NormalizedFilePath -> String -> k -> IO (Maybe (RuleResult k))-runHlintAction ideState normalizedFilePath desc rule = runAction desc ideState $ use rule normalizedFilePath--runGetFileContentsAction :: IdeState -> NormalizedFilePath -> IO (Maybe (FileVersion, Maybe T.Text))-runGetFileContentsAction ideState normalizedFilePath = runHlintAction ideState normalizedFilePath "Hlint.GetFileContents" GetFileContents--runGetModSummaryAction :: IdeState -> NormalizedFilePath -> IO (Maybe ModSummaryResult)-runGetModSummaryAction ideState normalizedFilePath = runHlintAction ideState normalizedFilePath "Hlint.GetModSummary" GetModSummary- -- ----------------------------------------------------------------------codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction-codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context)+codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction+codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context)   | let TextDocumentIdentifier uri = documentId   , Just docNormalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri)-  = liftIO $ fmap (Right . LSP.List . map LSP.InR) $ do+  = do+    verTxtDocId <- lift $ getVersionedTextDoc documentId+    liftIO $ fmap (InL . map LSP.InR) $ do       allDiagnostics <- atomically $ getDiagnostics ideState+       let numHintsInDoc = length             [diagnostic | (diagnosticNormalizedFilePath, _, diagnostic) <- allDiagnostics                         , validCommand diagnostic@@ -418,76 +419,70 @@             [diagnostic | diagnostic <- diags                         , validCommand diagnostic             ]-      file <- runGetFileContentsAction ideState docNormalizedFilePath-      singleHintCodeActions <--        if | Just (_, source) <- file -> do-               modSummaryResult <- runGetModSummaryAction ideState docNormalizedFilePath-               pure if | Just modSummaryResult <- modSummaryResult-                       , Just source <- source-                       , let dynFlags = ms_hspp_opts $ msrModSummary modSummaryResult ->-                           diags >>= diagnosticToCodeActions dynFlags source pluginId documentId-                       | otherwise -> []-           | otherwise -> pure []+      let singleHintCodeActions = diags >>= diagnosticToCodeActions verTxtDocId       if numHintsInDoc > 1 && numHintsInContext > 0 then do-        pure $ singleHintCodeActions ++ [applyAllAction]+        pure $ singleHintCodeActions ++ [applyAllAction verTxtDocId]       else         pure singleHintCodeActions   | otherwise-  = pure $ Right $ LSP.List []+  = pure $ InL []    where-    applyAllAction =-      let args = Just [toJSON (documentId ^. LSP.uri)]-          cmd = mkLspCommand pluginId "applyAll" "Apply all hints" args-        in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionQuickFix) Nothing Nothing Nothing Nothing (Just cmd) Nothing+    applyAllAction verTxtDocId =+      let args = Just $ toJSON (ApplyHint verTxtDocId Nothing)+        in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionKind_QuickFix) Nothing Nothing Nothing Nothing Nothing args      -- |Some hints do not have an associated refactoring-    validCommand (LSP.Diagnostic _ _ (Just (InR code)) (Just "hlint") _ _ _) =+    validCommand (LSP.Diagnostic _ _ (Just (InR code)) _ (Just "hlint") _ _ _ _) =         "refact:" `T.isPrefixOf` code     validCommand _ =         False -    LSP.List diags = context ^. LSP.diagnostics+    diags = context ^. LSP.diagnostics +resolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState HlintResolveCommands Method_CodeActionResolve+resolveProvider recorder ideState _plId ca uri resolveValue = do+  file <-  getNormalizedFilePathE uri+  case resolveValue of+    (ApplyHint verTxtDocId oneHint) -> do+        edit <- ExceptT $ liftIO $ applyHint recorder ideState file oneHint verTxtDocId+        pure $ ca & LSP.edit ?~ edit+    (IgnoreHint verTxtDocId hintTitle ) -> do+        edit <- ExceptT $ liftIO $ ignoreHint recorder ideState file verTxtDocId hintTitle+        pure $ ca & LSP.edit ?~ edit+ -- | Convert a hlint diagnostic into an apply and an ignore code action -- if applicable-diagnosticToCodeActions :: DynFlags -> T.Text -> PluginId -> TextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction]-diagnosticToCodeActions dynFlags fileContents pluginId documentId diagnostic+diagnosticToCodeActions :: VersionedTextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction]+diagnosticToCodeActions verTxtDocId diagnostic   | LSP.Diagnostic{ _source = Just "hlint", _code = Just (InR code), _range = LSP.Range start _ } <- diagnostic-  , let TextDocumentIdentifier uri = documentId   , let isHintApplicable = "refact:" `T.isPrefixOf` code   , let hint = T.replace "refact:" "" code   , let suppressHintTitle = "Ignore hint \"" <> hint <> "\" in this module"-  , let suppressHintTextEdits = mkSuppressHintTextEdits dynFlags fileContents hint-  , let suppressHintWorkspaceEdit =-          LSP.WorkspaceEdit-            (Just (Map.singleton uri (List suppressHintTextEdits)))-            Nothing-            Nothing+  , let suppressHintArguments = IgnoreHint verTxtDocId hint   = catMaybes       -- Applying the hint is marked preferred because it addresses the underlying error.       -- Disabling the rule isn't, because less often used and configuration can be adapted.       [ if | isHintApplicable            , let applyHintTitle = "Apply hint \"" <> hint <> "\""-                 applyHintArguments = [toJSON (AOP (documentId ^. LSP.uri) start hint)]-                 applyHintCommand = mkLspCommand pluginId "applyOne" applyHintTitle (Just applyHintArguments) ->-               Just (mkCodeAction applyHintTitle diagnostic Nothing (Just applyHintCommand) True)+                 applyHintArguments = ApplyHint verTxtDocId (Just $ OneHint start hint) ->+               Just (mkCodeAction applyHintTitle diagnostic (Just (toJSON applyHintArguments)) True)            | otherwise -> Nothing-      , Just (mkCodeAction suppressHintTitle diagnostic (Just suppressHintWorkspaceEdit) Nothing False)+      , Just (mkCodeAction suppressHintTitle diagnostic (Just (toJSON suppressHintArguments)) False)       ]   | otherwise = [] -mkCodeAction :: T.Text -> LSP.Diagnostic -> Maybe LSP.WorkspaceEdit -> Maybe LSP.Command -> Bool -> LSP.CodeAction-mkCodeAction title diagnostic workspaceEdit command isPreferred =+mkCodeAction :: T.Text -> LSP.Diagnostic -> Maybe Value -> Bool -> LSP.CodeAction+mkCodeAction title diagnostic data_  isPreferred =   LSP.CodeAction     { _title = title-    , _kind = Just LSP.CodeActionQuickFix-    , _diagnostics = Just (LSP.List [diagnostic])+    , _kind = Just LSP.CodeActionKind_QuickFix+    , _diagnostics = Just [diagnostic]     , _isPreferred = Just isPreferred     , _disabled = Nothing-    , _edit = workspaceEdit-    , _command = command-    , _xdata = Nothing+    , _edit = Nothing+    , _command = Nothing+    , _data_ = data_     }  mkSuppressHintTextEdits :: DynFlags -> T.Text -> T.Text -> [LSP.TextEdit]@@ -511,60 +506,52 @@     combinedTextEdit : lineSplitTextEditList -- --------------------------------------------------------------------- -applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri-applyAllCmd recorder ide uri = do-  let file = maybe (error $ show uri ++ " is not a file.")-                    toNormalizedFilePath'-                   (uriToFilePath' uri)-  withIndefiniteProgress "Applying all hints" Cancellable $ do-    res <- liftIO $ applyHint recorder ide file Nothing-    logWith recorder Debug $ LogApplying file res-    case res of-      Left err -> pure $ Left (responseError (T.pack $ "hlint:applyAll: " ++ show err))-      Right fs -> do-        _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ())-        pure $ Right Null+ignoreHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> VersionedTextDocumentIdentifier -> HintTitle -> IO (Either PluginError WorkspaceEdit)+ignoreHint _recorder ideState nfp verTxtDocId ignoreHintTitle = runExceptT $ do+  (_, fileContents) <- runActionE "Hlint.GetFileContents" ideState $ useE GetFileContents nfp+  (msr, _) <- runActionE "Hlint.GetModSummaryWithoutTimestamps" ideState $ useWithStaleE GetModSummaryWithoutTimestamps nfp+  case fileContents of+    Just contents -> do+        let dynFlags = ms_hspp_opts $ msrModSummary msr+            textEdits = mkSuppressHintTextEdits dynFlags contents ignoreHintTitle+            workspaceEdit =+                LSP.WorkspaceEdit+                  (Just (M.singleton (verTxtDocId ^. LSP.uri) textEdits))+                  Nothing+                  Nothing+        pure workspaceEdit+    Nothing -> throwError $ PluginInternalError "Unable to get fileContents"  -- -----------------------------------------------------------------------data ApplyOneParams = AOP-  { file      :: Uri-  , start_pos :: Position-  -- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.-  , hintTitle :: HintTitle-  } deriving (Eq,Show,Generic,FromJSON,ToJSON)+data HlintResolveCommands =+    ApplyHint+      { verTxtDocId :: VersionedTextDocumentIdentifier+      -- |If Nothing, apply all hints, otherise only apply+      -- the given hint+      , oneHint     :: Maybe OneHint+      }+  | IgnoreHint+      { verTxtDocId     :: VersionedTextDocumentIdentifier+      , ignoreHintTitle :: HintTitle+      } deriving (Generic, ToJSON, FromJSON)  type HintTitle = T.Text -data OneHint = OneHint-  { oneHintPos   :: Position-  , oneHintTitle :: HintTitle-  } deriving (Eq, Show)--applyOneCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState ApplyOneParams-applyOneCmd recorder ide (AOP uri pos title) = do-  let oneHint = OneHint pos title-  let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath'-                   (uriToFilePath' uri)-  let progTitle = "Applying hint: " <> title-  withIndefiniteProgress progTitle Cancellable $ do-    res <- liftIO $ applyHint recorder ide file (Just oneHint)-    logWith recorder Debug $ LogApplying file res-    case res of-      Left err -> pure $ Left (responseError (T.pack $ "hlint:applyOne: " ++ show err))-      Right fs -> do-        _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ())-        pure $ Right Null+data OneHint =+  OneHint+    { oneHintPos   :: Position+    , oneHintTitle :: HintTitle+    } deriving (Generic, Eq, Show, ToJSON, FromJSON) -applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit)-applyHint recorder ide nfp mhint =+applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit)+applyHint recorder ide nfp mhint verTxtDocId =   runExceptT $ do     let runAction' :: Action a -> IO a         runAction' = runAction "applyHint" ide     let errorHandlers = [ Handler $ \e -> return (Left (show (e :: IOException)))                         , Handler $ \e -> return (Left (show (e :: ErrorCall)))                         ]-    ideas <- bimapExceptT showParseError id $ ExceptT $ runAction' $ getIdeas recorder nfp+    ideas <- bimapExceptT (PluginInternalError . T.pack . showParseError) id $ ExceptT $ runAction' $ getIdeas recorder nfp     let ideas' = maybe ideas (`filterIdeas` ideas) mhint     let commands = map ideaRefactoring ideas'     logWith recorder Debug $ LogGeneratedIdeas nfp commands@@ -600,7 +587,7 @@     mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp     res <-         case mbParsedModule of-            Nothing -> throwE "Apply hint: error parsing the module"+            Nothing -> throwError "Apply hint: error parsing the module"             Just pm -> do                 let anns = pm_annotations pm                 let modu = pm_parsed_source pm@@ -614,11 +601,10 @@ #endif     case res of       Right appliedFile -> do-        let uri = fromNormalizedUri (filePathToUri' nfp)-        let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions+        let wsEdit = diffText' True (verTxtDocId, oldContent) (T.pack appliedFile) IncludeDeletions         ExceptT $ return (Right wsEdit)       Left err ->-        throwE err+        throwError $ PluginInternalError $ T.pack err     where           -- | If we are only interested in applying a particular hint then           -- let's filter out all the irrelevant ideas

@@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedLabels  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE TypeOperators     #-}@@ -6,20 +7,21 @@   ( main   ) where -import           Control.Lens            ((^.))-import           Control.Monad           (when)-import           Data.Aeson              (Value (..), object, toJSON, (.=))-import           Data.Functor            (void)-import           Data.List               (find)-import qualified Data.Map                as Map-import           Data.Maybe              (fromJust, isJust)-import qualified Data.Text               as T-import           Ide.Plugin.Config       (Config (..), PluginConfig (..))-import qualified Ide.Plugin.Config       as Plugin-import qualified Ide.Plugin.Hlint        as HLint-import           Ide.Types               (PluginId)-import qualified Language.LSP.Types.Lens as L-import           System.FilePath         ((</>))+import           Control.Lens               ((^.))+import           Control.Monad              (when)+import           Data.Aeson                 (Value (..), object, toJSON, (.=))+import           Data.Functor               (void)+import           Data.List                  (find)+import qualified Data.Map                   as Map+import           Data.Maybe                 (fromJust, isJust)+import           Data.Row                   ((.+), (.==))+import qualified Data.Text                  as T+import           Ide.Plugin.Config          (Config (..), PluginConfig (..))+import qualified Ide.Plugin.Config          as Plugin+import qualified Ide.Plugin.Hlint           as HLint+import           Ide.Types                  (PluginId)+import qualified Language.LSP.Protocol.Lens as L+import           System.FilePath            ((</>)) import           Test.Hls  main :: IO ()@@ -34,6 +36,7 @@     , configTests     , ignoreHintTests     , applyHintTests+    , resolveTests     ]  getIgnoreHintText :: T.Text -> T.Text@@ -42,6 +45,22 @@ getApplyHintText :: T.Text -> T.Text getApplyHintText name = "Apply hint \"" <> name <> "\"" +resolveTests :: TestTree+resolveTests = testGroup "hlint resolve tests"+  [+    ignoreHintGoldenResolveTest+      "Resolve version of: Ignore hint in this module inserts -Wno-unrecognised-pragmas and hlint ignore pragma if warn unrecognized pragmas is off"+      "UnrecognizedPragmasOff"+      (Point 3 8)+      "Eta reduce"+  , applyHintGoldenResolveTest+      "Resolve version of: [#2612] Apply hint works when operator fixities go right-to-left"+      "RightToLeftFixities"+      (Point 6 13)+      "Avoid reverse"+  ]++ ignoreHintTests :: TestTree ignoreHintTests = testGroup "hlint ignore hint tests"   [@@ -77,7 +96,7 @@         liftIO $ do             length diags @?= 2 -- "Eta Reduce" and "Redundant Id"             reduceDiag ^. L.range @?= Range (Position 1 0) (Position 1 12)-            reduceDiag ^. L.severity @?= Just DsInfo+            reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Information             reduceDiag ^. L.code @?= Just (InR "refact:Eta reduce")             reduceDiag ^. L.source @?= Just "hlint" @@ -123,15 +142,16 @@         doc <- openDoc "Base.hs" "haskell"         testHlintDiagnostics doc -        let change = TextDocumentContentChangeEvent-                        (Just (Range (Position 1 8) (Position 1 12)))-                         Nothing "x"+        let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 1 8) (Position 1 12)+                                                         .+ #rangeLength .== Nothing+                                                         .+ #text .== "x"         changeDoc doc [change]         expectNoMoreDiagnostics 3 doc "hlint" -        let change' = TextDocumentContentChangeEvent-                        (Just (Range (Position 1 8) (Position 1 12)))-                         Nothing "id x"+        let change' = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 1 8) (Position 1 12)+                                                          .+ #rangeLength .== Nothing+                                                          .+ #text .== "id x"+         changeDoc doc [change']         testHlintDiagnostics doc @@ -182,11 +202,11 @@         doc <- openDoc "IgnoreAnnHlint.hs" "haskell"         expectNoMoreDiagnostics 3 doc "hlint" -    , knownBrokenForGhcVersions [GHC92, GHC94] "apply-refact has different behavior on v0.10" $+    , knownBrokenForGhcVersions [GHC92, GHC94, GHC96] "apply-refact has different behavior on v0.10" $       testCase "apply-refact preserve regular comments" $ runHlintSession "" $ do         testRefactor "Comments.hs" "Redundant bracket" expectedComments -    , onlyRunForGhcVersions [GHC92, GHC94] "only run test for apply-refact-0.10" $+    , onlyRunForGhcVersions [GHC92, GHC94, GHC96] "only run test for apply-refact-0.10" $       testCase "apply-refact preserve regular comments" $ runHlintSession "" $ do         testRefactor "Comments.hs" "Redundant bracket" expectedComments' @@ -323,7 +343,7 @@         liftIO $ do             length diags' @?= 1             d ^. L.range @?= Range (Position 1 10) (Position 1 21)-            d ^. L.severity @?= Just DsInfo+            d ^. L.severity @?= Just DiagnosticSeverity_Information     ]  testDir :: FilePath@@ -331,7 +351,7 @@  runHlintSession :: FilePath -> Session a -> IO a runHlintSession subdir  =-    failIfSessionTimeout . runSessionWithServer hlintPlugin (testDir </> subdir)+    failIfSessionTimeout . runSessionWithServerAndCaps hlintPlugin codeActionNoResolveCaps (testDir </> subdir)  noHlintDiagnostics :: [Diagnostic] -> Assertion noHlintDiagnostics diags =@@ -419,5 +439,25 @@  setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintTest testName path =-  goldenWithHaskellDoc hlintPlugin testName testDir path "expected" "hs"+  goldenWithHaskellAndCaps codeActionNoResolveCaps hlintPlugin testName testDir path "expected" "hs" +ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree+ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName =+  goldenResolveTest testCaseName goldenFilename point (getIgnoreHintText hintName)++applyHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree+applyHintGoldenResolveTest testCaseName goldenFilename point hintName = do+  goldenResolveTest testCaseName goldenFilename point (getApplyHintText hintName)++goldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree+goldenResolveTest testCaseName goldenFilename point hintText =+  setupGoldenHlintResolveTest testCaseName goldenFilename $ \document -> do+    waitForDiagnosticsFromSource document "hlint"+    actions <- getAndResolveCodeActions document $ pointToRange point+    case find ((== Just hintText) . getCodeActionTitle) actions of+      Just (InR codeAction) -> executeCodeAction codeAction+      _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point++setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+setupGoldenHlintResolveTest testName path =+  goldenWithHaskellAndCaps codeActionResolveCaps hlintPlugin testName testDir path "expected" "hs"