diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs index 745195b36e..a980efc12d 100644 --- a/ghcide/test/exe/InitializeResponseTests.hs +++ b/ghcide/test/exe/InitializeResponseTests.hs @@ -77,13 +77,13 @@ tests = withResource acquire release tests where testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree - che title getActual expected = testCase title doTest - where - doTest = do - ir <- getInitializeResponse - let Just ExecuteCommandOptions {_commands = commands} = getActual $ innerCaps ir - commandNames = (!! 2) . T.splitOn ":" <$> commands - zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames) + che title getActual expected = testCase title $ do + ir <- getInitializeResponse + ExecuteCommandOptions {_commands = commands} <- case getActual $ innerCaps ir of + Just eco -> pure eco + Nothing -> assertFailure "Was expecting Just ExecuteCommandOptions, got Nothing" + let commandNames = (!! 2) . T.splitOn ":" <$> commands + zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames) innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c @@ -93,5 +93,5 @@ tests = withResource acquire release tests where acquire = run initializeResponse release :: TResponseMessage Method_Initialize -> IO () - release = const $ pure () + release = mempty diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 8fa5dc06b7..1a94a5ddeb 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1439,7 +1439,7 @@ common refactor cpp-options: -Dhls_refactor library hls-refactor-plugin - import: defaults, warnings + import: defaults, pedantic, warnings exposed-modules: Development.IDE.GHC.ExactPrint Development.IDE.GHC.Compat.ExactPrint Development.IDE.Plugin.CodeAction @@ -1473,7 +1473,6 @@ library hls-refactor-plugin , bytestring , ghc-boot , regex-tdfa - , text-rope , ghcide == 2.6.0.0 , hls-plugin-api == 2.6.0.0 , lsp @@ -1497,7 +1496,7 @@ library hls-refactor-plugin , parser-combinators test-suite hls-refactor-plugin-tests - import: defaults, test-defaults, warnings + import: defaults, pedantic, test-defaults, warnings type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-refactor-plugin/test main-is: Main.hs diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs index affd44e1bc..93da3ba76f 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs @@ -42,7 +42,7 @@ showAstDataHtml a0 = html $ pre = tag "pre" showAstDataHtml' :: Data a => a -> SDoc showAstDataHtml' = - (generic + generic `ext1Q` list `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan `extQ` annotation @@ -73,7 +73,6 @@ showAstDataHtml a0 = html $ `extQ` srcSpanAnnP `extQ` srcSpanAnnC `extQ` srcSpanAnnN - ) where generic :: Data a => a -> SDoc generic t = nested (text $ showConstr (toConstr t)) @@ -157,15 +156,15 @@ showAstDataHtml a0 = html $ srcSpan :: SrcSpan -> SDoc srcSpan ss = char ' ' <> - (hang (ppr ss) 1 + hang (ppr ss) 1 -- TODO: show annotations here - (text "")) + (text "") realSrcSpan :: RealSrcSpan -> SDoc realSrcSpan ss = braces $ char ' ' <> - (hang (ppr ss) 1 + hang (ppr ss) 1 -- TODO: show annotations here - (text "")) + (text "") addEpAnn :: AddEpAnn -> SDoc addEpAnn (AddEpAnn a s) = text "AddEpAnn" <+> ppr a <+> epaAnchor s @@ -202,7 +201,7 @@ showAstDataHtml a0 = html $ located :: (Data a, Data b) => GenLocated a b -> SDoc located (L ss a) - = nested "L" $ (li (showAstDataHtml' ss) $$ li (showAstDataHtml' a)) + = nested "L" (li (showAstDataHtml' ss) $$ li (showAstDataHtml' a)) -- ------------------------- @@ -245,7 +244,7 @@ showAstDataHtml a0 = html $ annotationEpaLocation = annotation' (text "EpAnn EpaLocation") annotation' :: forall a. Data a => SDoc -> EpAnn a -> SDoc - annotation' tag anns = nested (text $ showConstr (toConstr anns)) + annotation' _tag anns = nested (text $ showConstr (toConstr anns)) (vcat (map li $ gmapQ showAstDataHtml' anns)) -- ------------------------- diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index f249711e4c..cd91743756 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- | This module hosts various abstractions and utility functions to work with ghc-exactprint. module Development.IDE.GHC.ExactPrint @@ -29,6 +30,7 @@ module Development.IDE.GHC.ExactPrint removeComma, -- * Helper function eqSrcSpan, + eqSrcSpanA, epl, epAnn, removeTrailingComma, @@ -434,7 +436,7 @@ modifySmallestDeclWithM validSpan f a = do TransformT (lift $ validSpan $ locA src) >>= \case True -> do (decs', r) <- f ldecl - pure $ (DL.fromList decs' <> DL.fromList rest, Just r) + pure (DL.fromList decs' <> DL.fromList rest, Just r) False -> first (DL.singleton ldecl <>) <$> modifyMatchingDecl rest modifyDeclsT' (fmap (first DL.toList) . modifyMatchingDecl) a @@ -476,7 +478,7 @@ modifySigWithM :: TransformT m a modifySigWithM queryId f a = do let modifyMatchingSigD :: [LHsDecl GhcPs] -> TransformT m (DL.DList (LHsDecl GhcPs)) - modifyMatchingSigD [] = pure (DL.empty) + modifyMatchingSigD [] = pure DL.empty modifyMatchingSigD (ldecl@(L annSigD (SigD xsig (TypeSig xTypeSig ids (HsWC xHsWc lHsSig)))) : rest) | queryId `elem` (unLoc <$> ids) = do let newSig = f lHsSig @@ -546,7 +548,7 @@ modifyMgMatchesT' (MG xMg (L locMatches matches)) f def combineResults = do modifyMgMatchesT' (MG xMg (L locMatches matches) originMg) f def combineResults = do (unzip -> (matches', rs)) <- mapM f matches r' <- lift $ foldM combineResults def rs - pure $ (MG xMg (L locMatches matches') originMg, r') + pure (MG xMg (L locMatches matches') originMg, r') #endif graftSmallestDeclsWithM :: @@ -690,7 +692,7 @@ eqSrcSpan l r = leftmost_smallest l r == EQ -- | Equality on SrcSpan's. -- Ignores the (Maybe BufSpan) field of SrcSpan's. -eqSrcSpanA :: SrcAnn la -> SrcAnn b -> Bool +eqSrcSpanA :: SrcAnn a -> SrcAnn b -> Bool eqSrcSpanA l r = leftmost_smallest (locA l) (locA r) == EQ addParensToCtxt :: Maybe EpaLocation -> AnnContext -> AnnContext @@ -715,7 +717,7 @@ modifyAnns x f = first ((fmap.fmap) f) x removeComma :: SrcSpanAnnA -> SrcSpanAnnA removeComma it@(SrcSpanAnn EpAnnNotUsed _) = it removeComma (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l) - = (SrcSpanAnn (EpAnn anc (AnnListItem (filter (not . isCommaAnn) as)) cs) l) + = SrcSpanAnn (EpAnn anc (AnnListItem (filter (not . isCommaAnn) as)) cs) l where isCommaAnn AddCommaAnn{} = True isCommaAnn _ = False diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index cd96758b39..f969ac1fdf 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -40,7 +40,6 @@ import Data.Ord (comparing) import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Text.Utf16.Rope as Rope import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service @@ -102,8 +101,7 @@ import Language.LSP.Protocol.Types (ApplyWorkspa type (|?) (InL, InR), uriToFilePath) import qualified Language.LSP.Server as LSP -import Language.LSP.VFS (VirtualFile, - virtualFileText) +import Language.LSP.VFS (virtualFileText) import qualified Text.Fuzzy.Parallel as TFP import qualified Text.Regex.Applicative as RE import Text.Regex.TDFA ((=~), (=~~)) @@ -122,7 +120,7 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod let actions = caRemoveRedundantImports parsedModule text diag xs uri <> caRemoveInvalidExports parsedModule text diag xs uri - pure $ InL $ actions + pure $ InL actions ------------------------------------------------------------------------------------------------- @@ -191,7 +189,7 @@ extendImportHandler :: CommandFunction IdeState ExtendImport extendImportHandler ideState _ edit@ExtendImport {..} = ExceptT $ do res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do - let (_, (head -> TextEdit {_range})) = fromJust $ _changes >>= listToMaybe . M.toList + let (_, head -> TextEdit {_range}) = fromJust $ _changes >>= listToMaybe . M.toList srcSpan = rangeToSrcSpan nfp _range LSP.sendNotification SMethod_WindowShowMessage $ ShowMessageParams MessageType_Info $ @@ -389,7 +387,6 @@ suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range} findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs) findImportDeclByModuleName decls modName = flip find decls $ \case (L _ ImportDecl {..}) -> modName == moduleNameString (unLoc ideclName) - _ -> error "impossible" isTheSameLine :: SrcSpan -> SrcSpan -> Bool isTheSameLine s1 s2 @@ -637,7 +634,6 @@ suggestDeleteUnusedBinding case grhssLocalBinds of (HsValBinds _ (ValBinds _ bag lsigs)) -> go bag lsigs _ -> [] - findRelatedSpanForMatch _ _ _ = [] findRelatedSpanForHsBind :: PositionIndexedString @@ -1123,8 +1119,6 @@ targetModuleName :: ModuleTarget -> ModuleName targetModuleName ImplicitPrelude{} = mkModuleName "Prelude" targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) = unLoc ideclName -targetModuleName (ExistingImp _) = - error "Cannot happen!" disambiguateSymbol :: Annotated ParsedSource -> @@ -1538,7 +1532,8 @@ constructNewImportSuggestions constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules qis = nubOrdBy simpleCompareImportSuggestion [ suggestion | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing] -- strip away qualified module names from the unknown name - , identInfo <- maybe [] Set.toList $ (lookupOccEnv (getExportsMap exportsMap) (mkVarOrDataOcc name)) <> (lookupOccEnv (getExportsMap exportsMap) (mkTypeOcc name)) -- look up the modified unknown name in the export map + , identInfo <- maybe [] Set.toList $ lookupOccEnv (getExportsMap exportsMap) (mkVarOrDataOcc name) + <> lookupOccEnv (getExportsMap exportsMap) (mkTypeOcc name) -- look up the modified unknown name in the export map , canUseIdent thingMissing identInfo -- check if the identifier information retrieved can be used , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules -- check if the module of the identifier is allowed , suggestion <- renderNewImport identInfo -- creates a list of import suggestions for the retrieved identifier information diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs index 49438ec4cc..7601b4f9e7 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -19,6 +19,7 @@ import Control.Monad.Reader import Control.Monad.Trans.Maybe import Data.Either (fromRight, partitionEithers) +import Data.Functor ((<&>)) import Data.IORef.Extra import qualified Data.Map as Map import Data.Maybe (fromMaybe) @@ -52,7 +53,6 @@ type GhcideCodeAction = ExceptT PluginError (ReaderT CodeActionArgs IO) GhcideCo ------------------------------------------------------------------------------------------------- -{-# ANN runGhcideCodeAction ("HLint: ignore Move guards forward" :: String) #-} runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams Method_TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = diags}) codeAction = do let mbFile = toNormalizedFilePath' <$> uriToFilePath uri @@ -70,9 +70,9 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments caaContents <- onceIO $ - runRule GetFileContents >>= \case - Just (_, txt) -> pure txt - _ -> pure Nothing + runRule GetFileContents <&> \case + Just (_, txt) -> txt + Nothing -> Nothing caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource caaTmr <- onceIO $ runRule TypeCheck @@ -80,18 +80,16 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra caaBindings <- onceIO $ runRule GetBindings caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs results <- liftIO $ - sequence - [ runReaderT (runExceptT codeAction) caa - | caaDiagnostic <- diags, - let caa = CodeActionArgs {..} + [ runReaderT (runExceptT codeAction) CodeActionArgs {..} + | caaDiagnostic <- diags ] - let (errs, successes) = partitionEithers results + let (_errs, successes) = partitionEithers results pure $ concat successes mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) mkCA title kind isPreferred diags edit = - InR $ CodeAction title kind (Just $ diags) isPreferred Nothing (Just edit) Nothing Nothing + InR $ CodeAction title kind (Just diags) isPreferred Nothing (Just edit) Nothing Nothing mkGhcideCAPlugin :: GhcideCodeAction -> PluginId -> T.Text -> PluginDescriptor IdeState mkGhcideCAPlugin codeAction plId desc = diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 54aaf35308..63a8d8e14c 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -82,7 +82,7 @@ rewriteToEdit :: HasCallStack => Either String [TextEdit] rewriteToEdit dflags (Rewrite dst f) = do - (ast, anns , _) <- runTransformT + (ast, _ , _) <- runTransformT $ do ast <- f dflags pure $ traceAst "REWRITE_result" $ resetEntryDP ast @@ -209,10 +209,6 @@ lastMaybe :: [a] -> Maybe a lastMaybe [] = Nothing lastMaybe other = Just $ last other -liftMaybe :: String -> Maybe a -> TransformT (Either String) a -liftMaybe _ (Just x) = return x -liftMaybe s _ = TransformT $ lift $ Left s - ------------------------------------------------------------------------------ extendImport :: Maybe String -> String -> LImportDecl GhcPs -> Rewrite extendImport mparent identifier lDecl@(L l _) = @@ -243,7 +239,7 @@ extendImportTopLevel thing (L l it@ImportDecl{..}) #else | Just (hide, L l' lies) <- ideclHiding #endif - , hasSibling <- not $ null lies = do + = do src <- uniqueSrcSpanT top <- uniqueSrcSpanT let rdr = reLocA $ L src $ mkRdrUnqual $ mkVarOcc thing @@ -312,7 +308,7 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) where go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs) | parent == unIEWrappedName ie = TransformT $ lift . Left $ child <> " already included in " <> parent <> " imports" - go hide l' pre (lAbs@(L ll' (IEThingAbs _ absIE@(L _ ie))) : xs) + go hide l' pre ((L ll' (IEThingAbs _ absIE@(L _ ie))) : xs) -- ThingAbs ie => ThingWith ie child | parent == unIEWrappedName ie = do srcChild <- uniqueSrcSpanT @@ -347,15 +343,14 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) #endif thing = IEThingWith newl twIE (IEWildcard 2) [] #if MIN_VERSION_ghc(9,7,0) - newl = fmap (\ann -> ann ++ [(AddEpAnn AnnDotdot d0)]) <$> l''' + newl = fmap (\ann -> ann ++ [AddEpAnn AnnDotdot d0]) <$> l''' #else - newl = (\ann -> ann ++ [(AddEpAnn AnnDotdot d0)]) <$> l''' + newl = (\ann -> ann ++ [AddEpAnn AnnDotdot d0]) <$> l''' #endif lies = L l' $ reverse pre ++ [L l'' thing] ++ xs return $ L l it' - | parent == unIEWrappedName ie - , hasSibling <- not $ null lies' = - do + | parent == unIEWrappedName ie = do + let hasSibling = not $ null lies' srcChild <- uniqueSrcSpanT let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child childRdr <- pure $ setEntryDP childRdr $ SameLine $ if hasSibling then 1 else 0 @@ -380,8 +375,7 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) fixLast = if hasSibling then first addComma else id return $ L l it' go hide l' pre (x : xs) = go hide l' (x : pre) xs - go hide l' pre [] - | hasSibling <- not $ null pre = do + go hide l' pre [] = do -- [] => ThingWith parent [child] l'' <- uniqueSrcSpanT srcParent <- uniqueSrcSpanT @@ -389,12 +383,12 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) parentRdr <- liftParseAST df parent let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child isParentOperator = hasParen parent - let parentLIE = reLocA $ L srcParent $ (if isParentOperator then IEType (epl 0) parentRdr' + let parentLIE = reLocA $ L srcParent $ if isParentOperator then IEType (epl 0) parentRdr' else IEName #if MIN_VERSION_ghc(9,5,0) noExtField #endif - parentRdr') + parentRdr' parentRdr' = modifyAnns parentRdr $ \case it@NameAnn{nann_adornment = NameParens} -> it{nann_open = epl 1, nann_close = epl 0} other -> other @@ -440,7 +434,7 @@ addCommaInImportList lies x = _ -> Nothing pure $ any isTrailingAnnComma (lann_trailing lastItemAnn) - hasSibling = not . null $ lies + hasSibling = not $ null lies -- Setup the new item. It should have a preceding whitespace if it has siblings, and a trailing comma if the -- preceding item already has one. @@ -480,8 +474,6 @@ hideSymbol symbol lidecl@(L loc ImportDecl{..}) = Just (True, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides) Just (False, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl imports #endif -hideSymbol _ (L _ (XImportDecl _)) = - error "cannot happen" extendHiding :: String -> @@ -534,7 +526,7 @@ deleteFromImport :: XRec GhcPs [LIE GhcPs] -> DynFlags -> TransformT (Either String) (LImportDecl GhcPs) -deleteFromImport (T.pack -> symbol) (L l idecl) llies@(L lieLoc lies) _ = do +deleteFromImport (T.pack -> symbol) (L l idecl) (L lieLoc lies) _ = do let edited = L lieLoc deletedLies lidecl' = L l $ diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 0918410489..7ab1d80c76 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -7,6 +7,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- don't warn about usage HasCallStack module Main ( main @@ -47,7 +48,6 @@ import Text.Regex.TDFA ((=~)) import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports) import Test.Hls -import Control.Applicative (liftA2) import qualified Development.IDE.Plugin.CodeAction as Refactor import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import qualified Test.AddArgument @@ -90,24 +90,25 @@ initializeTests = withResource acquire release tests testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree - che title getActual expected = testCase title doTest - where - doTest = do - ir <- getInitializeResponse - let Just ExecuteCommandOptions {_commands = commands} = getActual $ innerCaps ir - -- Check if expected exists in commands. Note that commands can arrive in different order. - mapM_ (\e -> any (\o -> T.isSuffixOf e o) commands @? show (expected, show commands)) expected + che title getActual expected = testCase title $ do + ir <- getInitializeResponse + ExecuteCommandOptions {_commands = commands} <- case getActual $ innerCaps ir of + Just eco -> pure eco + Nothing -> assertFailure "Was expecting Just ExecuteCommandOptions, got Nothing" + -- Check if expected exists in commands. Note that commands can arrive in different order. + mapM_ (\e -> any (\o -> T.isSuffixOf e o) commands @? show (expected, show commands)) expected acquire :: IO (TResponseMessage Method_Initialize) acquire = run initializeResponse release :: TResponseMessage Method_Initialize -> IO () - release = const $ pure () + release = mempty innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" + completionTests :: TestTree completionTests = testGroup "auto import snippets" @@ -264,24 +265,23 @@ completionCommandTest name src pos wanted expected = testSession name $ do docId <- createDoc "A.hs" "haskell" (T.unlines src) _ <- waitForDiagnostics compls <- skipManyTill anyMessage (getCompletions docId pos) - let wantedC = find ( \case - CompletionItem {_insertText = Just x - ,_command = Just _} -> wanted `T.isPrefixOf` x - _ -> False - ) compls + let wantedC = mapMaybe (\case + CompletionItem {_insertText = Just x, _command = Just cmd} + | wanted `T.isPrefixOf` x -> Just cmd + _ -> Nothing + ) compls case wantedC of - Nothing -> - liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls] - Just CompletionItem {..} -> do - c <- assertJust "Expected a command" _command - executeCommand c + [] -> + liftIO $ assertFailure $ "Cannot find completion " <> show wanted <> " in: " <> show [_label | CompletionItem {_label} <- compls] + command:_ -> do + executeCommand command if src /= expected - then do - modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId) - liftIO $ modifiedCode @?= T.unlines expected - else do - expectMessages SMethod_WorkspaceApplyEdit 1 $ \edit -> - liftIO $ assertFailure $ "Expected no edit but got: " <> show edit + then do + modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId) + liftIO $ modifiedCode @?= T.unlines expected + else do + expectMessages SMethod_WorkspaceApplyEdit 1 $ \edit -> + liftIO $ assertFailure $ "Expected no edit but got: " <> show edit completionNoCommandTest :: TestName -> [T.Text] -> Position -> T.Text -> TestTree completionNoCommandTest name src pos wanted = testSession name $ do @@ -1493,15 +1493,16 @@ extendImportTests = testGroup "extend import actions" template setUpModules moduleUnderTest range expectedTitles expectedContentB = do configureCheckProject overrideCheckProject - mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules + mapM_ (\(fileName, contents) -> createDoc fileName "haskell" contents) setUpModules docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) _ <- waitForDiagnostics waitForProgressDone actionsOrCommands <- getCodeActions docB range let codeActions = - filter - (liftA2 (&&) (T.isPrefixOf "Add") (not . T.isPrefixOf "Add argument") . codeActionTitle) - [ca | InR ca <- actionsOrCommands] + [ ca | InR ca <- actionsOrCommands + , let title = codeActionTitle ca + , "Add" `T.isPrefixOf` title && not ("Add argument" `T.isPrefixOf` title) + ] actualTitles = codeActionTitle <$> codeActions -- Note that we are not testing the order of the actions, as the -- order of the expected actions indicates which one we'll execute @@ -1511,9 +1512,8 @@ extendImportTests = testGroup "extend import actions" -- Execute the action with the same title as the first expected one. -- Since we tested that both lists have the same elements (possibly -- in a different order), this search cannot fail. - let firstTitle:_ = expectedTitles - action = fromJust $ - find ((firstTitle ==) . codeActionTitle) codeActions + firstTitle:_ <- pure expectedTitles + Just action <- pure $ find ((firstTitle ==) . codeActionTitle) codeActions executeCodeAction action contentAfterAction <- documentContents docB liftIO $ expectedContentB @=? contentAfterAction @@ -1530,13 +1530,13 @@ fixModuleImportTypoTests = testGroup "fix module import typo" , testSession "works when multiple modules suggested" $ do doc <- createDoc "A.hs" "haskell" "import Data.I" _ <- waitForDiagnostics - actions <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> getCodeActions doc (R 0 0 0 10) - let actionTitles = [ title | InR CodeAction{_title=title} <- actions ] - liftIO $ actionTitles @?= [ "replace with Data.Eq" - , "replace with Data.Int" - , "replace with Data.Ix" - ] - let InR replaceWithDataEq : _ = actions + actions <- getCodeActions doc (R 0 0 0 10) + traverse_ (assertActionWithTitle actions) + [ "replace with Data.Eq" + , "replace with Data.Int" + , "replace with Data.Ix" + ] + replaceWithDataEq <- pickActionWithTitle "replace with Data.Eq" actions executeCodeAction replaceWithDataEq contentAfterAction <- documentContents doc liftIO $ contentAfterAction @?= "import Data.Eq" @@ -3735,9 +3735,3 @@ withTempDir f = System.IO.Extra.withTempDir $ \dir -> brokenForGHC94 :: String -> TestTree -> TestTree brokenForGHC94 = knownBrokenForGhcVersions [GHC94] - --- | Assert that a value is not 'Nothing', and extract the value. -assertJust :: MonadIO m => String -> Maybe a -> m a -assertJust s = \case - Nothing -> liftIO $ assertFailure s - Just x -> pure x diff --git a/plugins/hls-refactor-plugin/test/Test/AddArgument.hs b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs index 18e824997b..1816bd2a90 100644 --- a/plugins/hls-refactor-plugin/test/Test/AddArgument.hs +++ b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs @@ -7,7 +7,6 @@ module Test.AddArgument (tests) where -import Data.List.Extra import qualified Data.Text as T import Development.IDE.Types.Location import Language.LSP.Protocol.Types hiding @@ -54,9 +53,11 @@ mkGoldenAddArgTest' :: FilePath -> Range -> T.Text -> TestTree mkGoldenAddArgTest' testFileName range varName = do let action docB = do _ <- waitForDiagnostics + let matchAction a = case a of + InR CodeAction {_title = t} -> "Add" `T.isPrefixOf` t + _ -> False InR action@CodeAction {_title = actionTitle} : _ <- - filter (\(InR CodeAction {_title = x}) -> "Add" `isPrefixOf` T.unpack x) - <$> getCodeActions docB range + filter matchAction <$> getCodeActions docB range liftIO $ actionTitle @?= ("Add argument ‘" <> varName <> "’ to function") executeCodeAction action goldenWithHaskellDocInTmpDir