diff --git a/.hlint.yaml b/.hlint.yaml index e1fbcecaaf..a6c6f29b0a 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -107,7 +107,6 @@ - Ide.Plugin.Eval.Util - Ide.Plugin.Floskell - Ide.Plugin.ModuleName - - Ide.Plugin.Rename - Ide.Plugin.Class.ExactPrint - TExpectedActual - TRigidType diff --git a/cabal.project b/cabal.project index 5e97a20001..e4097d484c 100644 --- a/cabal.project +++ b/cabal.project @@ -19,7 +19,7 @@ benchmarks: True write-ghc-environment-files: never -- Many of our tests only work single-threaded, and the only way to --- ensure tasty runs everything purely single-threaded is to pass +-- ensure tasty runs everything purely single-threaded is to pass -- this at the top-level test-options: -j1 @@ -72,5 +72,3 @@ if impl(ghc >= 9.7) -- this is okay allow-newer: ekg-core:text, - -- https://github.com/haskell-primitive/primitive-unlifted/issues/39 - primitive-unlifted:bytestring, diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 0c4d575883..8e1508cdd2 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -95,10 +95,10 @@ foiReferencesAtPoint file pos (FOIReferences asts) = adjustedLocs = HM.foldr go [] asts go (HAR _ _ rf tr _, goMapping) xs = refs ++ typerefs ++ xs where - refs = mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation . fst) - $ concat $ mapMaybe (\n -> M.lookup (Right n) rf) names - typerefs = mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation) - $ concat $ mapMaybe (`M.lookup` tr) names + refs = concatMap (mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation . fst)) + (mapMaybe (\n -> M.lookup (Right n) rf) names) + typerefs = concatMap (mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation)) + (mapMaybe (`M.lookup` tr) names) in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts) getNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name] diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index 85e9cd7fd6..27a4d88323 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -31,7 +31,7 @@ import Language.LSP.Test import System.Directory import System.FilePath import System.IO.Extra hiding (withTempDir) --- import Test.QuickCheck.Instances () + import Control.Lens ((^.)) import Control.Monad.Extra (whenJust) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index 7175211f34..92d332522f 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -290,7 +290,7 @@ checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpecta assertOneDefinitionFound :: [Location] -> Session Location assertOneDefinitionFound [def] = pure def - assertOneDefinitionFound _ = liftIO $ assertFailure "Expecting exactly one definition" + assertOneDefinitionFound xs = liftIO . assertFailure $ "Expecting exactly one definition, got " <> show (length xs) assertRangeCorrect Location{_range = foundRange} expectedRange = liftIO $ expectedRange @=? foundRange diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index de60d7fc0b..9bbb097060 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -105,7 +105,7 @@ flag isolateCabalfmtTests manual: True library hls-cabal-fmt-plugin - import: defaults, warnings + import: defaults, pedantic, warnings exposed-modules: Ide.Plugin.CabalFmt hs-source-dirs: plugins/hls-cabal-fmt-plugin/src build-depends: @@ -121,7 +121,7 @@ library hls-cabal-fmt-plugin , text test-suite hls-cabal-fmt-plugin-tests - import: defaults, test-defaults, warnings + import: defaults, pedantic, test-defaults, warnings type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-cabal-fmt-plugin/test main-is: Main.hs @@ -150,7 +150,7 @@ common cabal cpp-options: -Dhls_cabal library hls-cabal-plugin - import: defaults, warnings + import: defaults, pedantic, warnings exposed-modules: Ide.Plugin.Cabal Ide.Plugin.Cabal.Diagnostics @@ -193,7 +193,7 @@ library hls-cabal-plugin hs-source-dirs: plugins/hls-cabal-plugin/src test-suite hls-cabal-plugin-tests - import: defaults, test-defaults, warnings + import: defaults, pedantic, test-defaults, warnings type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-cabal-plugin/test main-is: Main.hs @@ -210,7 +210,6 @@ test-suite hls-cabal-plugin-tests , haskell-language-server:hls-cabal-plugin , hls-test-utils == 2.6.0.0 , lens - , lsp , lsp-types , text , text-rope @@ -232,7 +231,7 @@ common class cpp-options: -Dhls_class library hls-class-plugin - import: defaults, warnings + import: defaults, pedantic, warnings exposed-modules: Ide.Plugin.Class other-modules: Ide.Plugin.Class.CodeAction , Ide.Plugin.Class.CodeLens @@ -262,14 +261,13 @@ library hls-class-plugin OverloadedStrings test-suite hls-class-plugin-tests - import: defaults, test-defaults, warnings + import: defaults, pedantic, test-defaults, warnings type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-class-plugin/test main-is: Main.hs build-depends: , base , filepath - , ghcide , haskell-language-server:hls-class-plugin , hls-test-utils == 2.6.0.0 , lens @@ -292,7 +290,7 @@ common callHierarchy cpp-options: -Dhls_callHierarchy library hls-call-hierarchy-plugin - import: defaults, warnings + import: defaults, pedantic, warnings buildable: True exposed-modules: Ide.Plugin.CallHierarchy other-modules: @@ -317,7 +315,7 @@ library hls-call-hierarchy-plugin default-extensions: DataKinds test-suite hls-call-hierarchy-plugin-tests - import: defaults, test-defaults, warnings + import: defaults, pedantic, test-defaults, warnings type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-call-hierarchy-plugin/test main-is: Main.hs @@ -350,7 +348,7 @@ common eval cpp-options: -Dhls_eval library hls-eval-plugin - import: defaults, warnings, pedantic + import: defaults, pedantic, warnings exposed-modules: Ide.Plugin.Eval Ide.Plugin.Eval.Types @@ -396,7 +394,7 @@ library hls-eval-plugin DataKinds test-suite hls-eval-plugin-tests - import: defaults, test-defaults, warnings + import: defaults, pedantic, test-defaults, warnings type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-eval-plugin/test main-is: Main.hs @@ -482,13 +480,12 @@ common rename cpp-options: -Dhls_rename library hls-rename-plugin - import: defaults, warnings + import: defaults, pedantic, warnings exposed-modules: Ide.Plugin.Rename hs-source-dirs: plugins/hls-rename-plugin/src build-depends: , base >=4.12 && <5 , containers - , extra , ghcide == 2.6.0.0 , hashable , hiedb @@ -507,7 +504,7 @@ library hls-rename-plugin test-suite hls-rename-plugin-tests - import: defaults, test-defaults, warnings + import: defaults, pedantic, test-defaults, warnings type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-rename-plugin/test main-is: Main.hs @@ -593,7 +590,7 @@ common hlint cpp-options: -Dhls_hlint library hls-hlint-plugin - import: defaults, warnings, pedantic + import: defaults, pedantic, warnings, pedantic exposed-modules: Ide.Plugin.Hlint hs-source-dirs: plugins/hls-hlint-plugin/src build-depends: @@ -627,7 +624,7 @@ library hls-hlint-plugin DataKinds test-suite hls-hlint-plugin-tests - import: defaults, test-defaults, warnings + import: defaults, pedantic, test-defaults, warnings type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-hlint-plugin/test main-is: Main.hs diff --git a/hls-plugin-api/src/Ide/Plugin/Properties.hs b/hls-plugin-api/src/Ide/Plugin/Properties.hs index 6d65adb9cb..ae3d505562 100644 --- a/hls-plugin-api/src/Ide/Plugin/Properties.hs +++ b/hls-plugin-api/src/Ide/Plugin/Properties.hs @@ -101,7 +101,7 @@ data SomePropertyKeyWithMetaData SomePropertyKeyWithMetaData (SPropertyKey k) (MetaData t) -- | 'Properties' is a partial implementation of json schema, without supporting union types and validation. --- In hls, it defines a set of properties which used in dedicated configuration of a plugin. +-- In hls, it defines a set of properties used in dedicated configuration of a plugin. -- A property is an immediate child of the json object in each plugin's "config" section. -- It was designed to be compatible with vscode's settings UI. -- Use 'emptyProperties' and 'useProperty' to create and consume 'Properties'. diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs index 6a59b2fb69..5bf0ef8838 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs @@ -14,7 +14,6 @@ import qualified Data.Text.Utf16.Lines as Rope (Position import Data.Text.Utf16.Rope.Mixed (Rope) import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE as D -import qualified Development.IDE.Plugin.Completions.Logic as Ghcide import qualified Development.IDE.Plugin.Completions.Types as Ghcide import Ide.Plugin.Cabal.Completion.Completer.Simple import Ide.Plugin.Cabal.Completion.Completer.Snippet diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index 8eac1bbd8f..06e9d99679 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -165,10 +165,6 @@ mkSymbol = \case -------------- Incoming calls and outgoing calls --------------------- ---------------------------------------------------------------------- -#if !MIN_VERSION_aeson(1,5,2) -deriving instance Ord Value -#endif - -- | Render incoming calls request. incomingCalls :: PluginMethodHandler IdeState Method_CallHierarchyIncomingCalls incomingCalls state _pluginId param = do diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index 55f127d4c2..ee5d57ced1 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -2,8 +2,6 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Main ( main @@ -13,10 +11,10 @@ import Control.Exception (catch) import Control.Lens (Prism', prism', view, (^.), (^..), (^?)) import Control.Monad (void) +import Data.Foldable (find) import Data.Maybe import Data.Row ((.==)) import qualified Data.Text as T -import Development.IDE.Core.Compile (sourceTypecheck) import qualified Ide.Plugin.Class as Class import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -47,35 +45,35 @@ codeActionTests = testGroup , "Add placeholders for all missing methods" , "Add placeholders for all missing methods with signature(s)" ] - , goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do - executeCodeAction eqAction - , goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $ \(_:_:neAction:_) -> do - executeCodeAction neAction - , goldenWithClass "Creates a placeholder for both '==' and '/='" "T1" "all" $ \(_:_:_:_:allMethodsAction:_) -> do - executeCodeAction allMethodsAction - , goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:_:_:_:_:fmapAction:_) -> do - executeCodeAction fmapAction - , goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do - executeCodeAction mmAction - , goldenWithClass "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:_:mmAction:_) -> do - executeCodeAction mmAction - , goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do - executeCodeAction _fAction - , goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do - executeCodeAction eqAction - , goldenWithClass "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $ \(gAction:_) -> do - executeCodeAction gAction - , goldenWithClass "Creates a placeholder for other two methods" "T6" "2" $ \(_:_:ghAction:_) -> do - executeCodeAction ghAction + , goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $ + getActionByTitle "Add placeholders for '=='" + , goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $ + getActionByTitle "Add placeholders for '/='" + , goldenWithClass "Creates a placeholder for both '==' and '/='" "T1" "all" $ + getActionByTitle "Add placeholders for all missing methods" + , goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ + getActionByTitle "Add placeholders for 'fmap'" + , goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $ + getActionByTitle "Add placeholders for 'f','g'" + , goldenWithClass "Creates a placeholder for multiple methods 2" "T3" "2" $ + getActionByTitle "Add placeholders for 'g','h'" + , goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $ + getActionByTitle "Add placeholders for '_f'" + , goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $ + getActionByTitle "Add placeholders for '=='" + , goldenWithClass "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $ + getActionByTitle "Add placeholders for 'g'" + , goldenWithClass "Creates a placeholder for other two methods" "T6" "2" $ + getActionByTitle "Add placeholders for 'g','h'" , onlyRunForGhcVersions [GHC92, GHC94] "Only ghc-9.2+ enabled GHC2021 implicitly" $ - goldenWithClass "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $ \(_:eqWithSig:_) -> do - executeCodeAction eqWithSig - , goldenWithClass "Insert pragma if not exist" "InsertWithoutPragma" "" $ \(_:eqWithSig:_) -> do - executeCodeAction eqWithSig - , goldenWithClass "Don't insert pragma if exist" "InsertWithPragma" "" $ \(_:eqWithSig:_) -> do - executeCodeAction eqWithSig - , goldenWithClass "Only insert pragma once" "InsertPragmaOnce" "" $ \(_:multi:_) -> do - executeCodeAction multi + goldenWithClass "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $ + getActionByTitle "Add placeholders for '==' with signature(s)" + , goldenWithClass "Insert pragma if not exist" "InsertWithoutPragma" "" $ + getActionByTitle "Add placeholders for '==' with signature(s)" + , goldenWithClass "Don't insert pragma if exist" "InsertWithPragma" "" $ + getActionByTitle "Add placeholders for '==' with signature(s)" + , goldenWithClass "Only insert pragma once" "InsertPragmaOnce" "" $ + getActionByTitle "Add placeholders for 'pure','<*>' with signature(s)" , expectCodeActionsAvailable "No code action available when minimal requirements meet" "MinimalDefinitionMeet" [] , expectCodeActionsAvailable "Add placeholders for all missing methods is unavailable when all methods are required" "AllMethodsRequired" [ "Add placeholders for 'f','g'" @@ -162,14 +160,20 @@ goldenCodeLens title path idx = executeCommand $ fromJust $ (lens !! idx) ^. L.command void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) -goldenWithClass ::TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree -goldenWithClass title path desc act = +goldenWithClass ::TestName -> FilePath -> FilePath -> ([CodeAction] -> Session CodeAction) -> TestTree +goldenWithClass title path desc findAction = goldenWithHaskellDoc def classPlugin title testDataDir path (desc <.> "expected") "hs" $ \doc -> do _ <- waitForDiagnosticsFrom doc actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc - act actions + action <- findAction actions + executeCodeAction action void $ skipManyTill anyMessage (getDocumentEdit doc) +getActionByTitle :: T.Text -> [CodeAction] -> Session CodeAction +getActionByTitle title actions = case find (\a -> a ^. L.title == title) actions of + Just a -> pure a + Nothing -> liftIO $ assertFailure $ "Action " <> show title <> " not found in " <> show [a ^. L.title | a <- actions] + expectCodeActionsAvailable :: TestName -> FilePath -> [T.Text] -> TestTree expectCodeActionsAvailable title path actionTitles = testCase title $ do diff --git a/plugins/hls-qualify-imported-names-plugin/test/Main.hs b/plugins/hls-qualify-imported-names-plugin/test/Main.hs index 824ce32065..1d932be601 100644 --- a/plugins/hls-qualify-imported-names-plugin/test/Main.hs +++ b/plugins/hls-qualify-imported-names-plugin/test/Main.hs @@ -38,9 +38,6 @@ makePoint line column | line >= 1 && column >= 1 = Point line column | otherwise = error "Line or column is less than 1." -isNotEmpty :: Foldable f => f a -> Bool -isNotEmpty = not . isEmpty - isEmpty :: Foldable f => f a -> Bool isEmpty = null diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 06efa793c2..c25da1bd46 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Ide.Plugin.Rename (descriptor, E.Log) where @@ -14,11 +15,13 @@ import Control.Monad.Except (ExceptT, throwError) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Class (lift) import Data.Bifunctor (first) +import Data.Foldable (fold) import Data.Generics import Data.Hashable import Data.HashSet (HashSet) import qualified Data.HashSet as HS -import Data.List.Extra hiding (length) +import Data.List.NonEmpty (NonEmpty ((:|)), + groupWith) import qualified Data.Map as M import Data.Maybe import Data.Mod.Word @@ -61,7 +64,7 @@ descriptor recorder pluginId = mkExactprintPluginDescriptor recorder $ (defaultP } renameProvider :: PluginMethodHandler IdeState Method_TextDocumentRename -renameProvider state pluginId (RenameParams _prog docId@(TextDocumentIdentifier uri) pos newNameText) = do +renameProvider state pluginId (RenameParams _prog (TextDocumentIdentifier uri) pos newNameText) = do nfp <- getNormalizedFilePathE uri directOldNames <- getNamesAtPos state nfp pos directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames @@ -70,8 +73,8 @@ renameProvider state pluginId (RenameParams _prog docId@(TextDocumentIdentifier indirect references through punned names. To find the transitive closure, we do a pass of the direct references to find the references for any punned names. See the `IndirectPuns` test for an example. -} - indirectOldNames <- concat . filter ((>1) . Prelude.length) <$> - mapM (uncurry (getNamesAtPos state) . locToFilePos) directRefs + indirectOldNames <- concat . filter ((>1) . length) <$> + mapM (uncurry (getNamesAtPos state) <=< locToFilePos) directRefs let oldNames = filter matchesDirect indirectOldNames ++ directOldNames matchesDirect n = occNameFS (nameOccName n) `elem` directFS where @@ -90,7 +93,7 @@ renameProvider state pluginId (RenameParams _prog docId@(TextDocumentIdentifier verTxtDocId <- lift $ getVersionedTextDoc (TextDocumentIdentifier uri) getSrcEdit state verTxtDocId (replaceRefs newName locations) fileEdits <- mapM getFileEdit filesRefs - pure $ InL $ foldl' (<>) mempty fileEdits + pure $ InL $ fold fileEdits -- | Limit renaming across modules. failWhenImportOrExport :: @@ -127,8 +130,8 @@ getSrcEdit state verTxtDocId updatePs = do nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) annAst <- runActionE "Rename.GetAnnotatedParsedSource" state (useE GetAnnotatedParsedSource nfp) - let (ps, anns) = (astA annAst, annsA annAst) - let src = T.pack $ exactPrint ps + let ps = astA annAst + src = T.pack $ exactPrint ps res = T.pack $ exactPrint (updatePs ps) pure $ diffText ccs (verTxtDocId, src) res IncludeDeletions @@ -142,7 +145,7 @@ replaceRefs newName refs = everywhere $ -- there has to be a better way... mkT (replaceLoc @AnnListItem) `extT` -- replaceLoc @AnnList `extT` -- not needed - -- replaceLoc @AnnParen `extT` -- not needed + -- replaceLoc @AnnParen `extT` -- not needed -- replaceLoc @AnnPragma `extT` -- not needed -- replaceLoc @AnnContext `extT` -- not needed -- replaceLoc @NoEpAnns `extT` -- not needed @@ -187,8 +190,8 @@ refsAtName state nfp name = do nameLocs :: Name -> (HieAstResult, PositionMapping) -> [Location] nameLocs name (HAR _ _ rm _ _, pm) = - mapMaybe (toCurrentLocation pm . realSrcSpanToLocation . fst) - (concat $ M.lookup (Right name) rm) + concatMap (mapMaybe (toCurrentLocation pm . realSrcSpanToLocation . fst)) + (M.lookup (Right name) rm) --------------------------------------------------------------------------------------------------- -- Util @@ -216,29 +219,20 @@ removeGenerated HAR{..} = HAR{hieAst = go hieAst,..} HieASTs (fmap goAst (getAsts hf)) goAst (Node nsi sp xs) = Node (SourcedNodeInfo $ M.restrictKeys (getSourcedNodeInfo nsi) (S.singleton SourceInfo)) sp (map goAst xs) --- head is safe since groups are non-empty collectWith :: (Hashable a, Eq b) => (a -> b) -> HashSet a -> [(b, HashSet a)] -collectWith f = map (\a -> (f $ head a, HS.fromList a)) . groupOn f . HS.toList +collectWith f = map (\(a :| as) -> (f a, HS.fromList (a:as))) . groupWith f . HS.toList locToUri :: Location -> Uri locToUri (Location uri _) = uri -nfpToUri :: NormalizedFilePath -> Uri -nfpToUri = filePathToUri . fromNormalizedFilePath - -showName :: Name -> String -showName = occNameString . getOccName - unsafeSrcSpanToLoc :: SrcSpan -> Location unsafeSrcSpanToLoc srcSpan = case srcSpanToLocation srcSpan of Nothing -> error "Invalid conversion from UnhelpfulSpan to Location" Just location -> location -locToFilePos :: Location -> (NormalizedFilePath, Position) -locToFilePos (Location uri (Range pos _)) = (nfp, pos) - where - Just nfp = (uriToNormalizedFilePath . toNormalizedUri) uri +locToFilePos :: Monad m => Location -> ExceptT PluginError m (NormalizedFilePath, Position) +locToFilePos (Location uri (Range pos _)) = (,pos) <$> getNormalizedFilePathE uri replaceModName :: Name -> Maybe ModuleName -> Module replaceModName name mbModName = diff --git a/plugins/hls-retrie-plugin/test/Main.hs b/plugins/hls-retrie-plugin/test/Main.hs index a34e84e053..8487f92599 100644 --- a/plugins/hls-retrie-plugin/test/Main.hs +++ b/plugins/hls-retrie-plugin/test/Main.hs @@ -49,24 +49,24 @@ inlineThisTests = testGroup "Inline this" ] ] - +testProvider :: TestName -> FilePath -> UInt -> UInt -> [Text] -> TestTree testProvider title file line row expected = testCase title $ runWithRetrie $ do adoc <- openDoc (file <.> "hs") "haskell" - waitForTypecheck adoc + _ <- waitForTypecheck adoc let position = Position line row codeActions <- getCodeActions adoc $ Range position position liftIO $ map codeActionTitle codeActions @?= map Just expected testCommand :: TestName -> FilePath -> UInt -> UInt -> TestTree testCommand title file row col = goldenWithRetrie title file $ \adoc -> do - waitForTypecheck adoc + _ <- waitForTypecheck adoc let p = Position row col codeActions <- getCodeActions adoc $ Range p p case codeActions of [InR ca] -> do executeCodeAction ca void $ skipManyTill anyMessage $ getDocumentEdit adoc - [] -> error "No code actions found" + cas -> liftIO . assertFailure $ "One code action expected, got " <> show (length cas) codeActionTitle :: (Command |? CodeAction) -> Maybe Text codeActionTitle (InR CodeAction {_title}) = Just _title