Fix -Wall in refactor plugin

ghcide/test/exe/InitializeResponseTests.hs

@@ -77,21 +77,24 @@ 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} <- assertJust "ExecuteCommandOptions" $ getActual $ innerCaps ir
+        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
   innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error"
 
+  assertJust :: String -> Maybe a -> IO a
+  assertJust s = \case
+    Nothing -> assertFailure $ "Expecting Just " <> s <> ", got Nothing"
+    Just x  -> pure x
+
   acquire :: IO (TResponseMessage Method_Initialize)
   acquire = run initializeResponse
 
   release :: TResponseMessage Method_Initialize -> IO ()
-  release = const $ pure ()
+  release = mempty
 

haskell-language-server.cabal

@@ -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

plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs

@@ -1,6 +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
     ( Graft(..),
@@ -29,6 +29,7 @@ module Development.IDE.GHC.ExactPrint
       removeComma,
       -- * Helper function
       eqSrcSpan,
+      eqSrcSpanA,
       epl,
       epAnn,
       removeTrailingComma,
@@ -690,7 +691,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

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                                   ((=~), (=~~))
@@ -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,7 @@ suggestDeleteUnusedBinding
         case grhssLocalBinds of
           (HsValBinds _ (ValBinds _ bag lsigs)) -> go bag lsigs
           _                                     -> []
-      findRelatedSpanForMatch _ _ _ = []
+      -- findRelatedSpanForMatch _ _ _ = []
 
       findRelatedSpanForHsBind
         :: PositionIndexedString
@@ -1123,8 +1120,6 @@ targetModuleName :: ModuleTarget -> ModuleName
 targetModuleName ImplicitPrelude{} = mkModuleName "Prelude"
 targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) =
     unLoc ideclName
-targetModuleName (ExistingImp _) =
-    error "Cannot happen!"
 
 disambiguateSymbol ::
     Annotated ParsedSource ->

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,28 +70,26 @@ 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
   caaHar <- onceIO $ runRule GetHieAst
   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 =

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
@@ -353,9 +349,8 @@ extendImportViaParent df parent child (L l it@ImportDecl{..})
 #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
@@ -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 $

plugins/hls-refactor-plugin/test/Main.hs

@@ -90,24 +90,27 @@ 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} <- assertJust "ExecuteCommandOptions" $ 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
 
     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"
 
+    assertJust :: String -> Maybe a -> IO a
+    assertJust s = \case
+      Nothing -> assertFailure $ "Expecting Just " <> s <> ", got Nothing"
+      Just x  -> pure x
+
 completionTests :: TestTree
 completionTests =
     testGroup "auto import snippets"