Skip to content

Commit 9ed7d45

Browse files
jhrcekjhrcek
committed
Fix -Wall in refactor plugin
1 parent 1bbe780 commit 9ed7d45

File tree

7 files changed

+43
-52
lines changed

7 files changed

+43
-52
lines changed

‎ghcide/test/exe/InitializeResponseTests.hs

Lines changed: 11 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -77,21 +77,24 @@ tests = withResource acquire release tests where
7777
testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
7878

7979
che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree
80-
che title getActual expected = testCase title doTest
81-
where
82-
doTest = do
83-
ir <- getInitializeResponse
84-
let Just ExecuteCommandOptions {_commands = commands} = getActual $ innerCaps ir
85-
commandNames = (!! 2) . T.splitOn ":" <$> commands
86-
zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames)
80+
che title getActual expected = testCase title $ do
81+
ir <- getInitializeResponse
82+
ExecuteCommandOptions {_commands = commands} <- assertJust "ExecuteCommandOptions" $ getActual $ innerCaps ir
83+
let commandNames = (!! 2) . T.splitOn ":" <$> commands
84+
zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames)
8785

8886
innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities
8987
innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c
9088
innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error"
9189

90+
assertJust :: String -> Maybe a -> IO a
91+
assertJust s = \case
92+
Nothing -> assertFailure $ "Expecting Just " <> s <> ", got Nothing"
93+
Just x -> pure x
94+
9295
acquire :: IO (TResponseMessage Method_Initialize)
9396
acquire = run initializeResponse
9497

9598
release :: TResponseMessage Method_Initialize -> IO ()
96-
release = const $ pure ()
99+
release = mempty
97100

‎haskell-language-server.cabal

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1473,7 +1473,6 @@ library hls-refactor-plugin
14731473
, bytestring
14741474
, ghc-boot
14751475
, regex-tdfa
1476-
, text-rope
14771476
, ghcide == 2.6.0.0
14781477
, hls-plugin-api == 2.6.0.0
14791478
, lsp

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

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
{-# LANGUAGE GADTs #-}
22
{-# LANGUAGE TypeFamilies #-}
3-
3+
{-# OPTIONS_GHC -Wno-orphans #-}
44
-- | This module hosts various abstractions and utility functions to work with ghc-exactprint.
55
module Development.IDE.GHC.ExactPrint
66
( Graft(..),
@@ -29,6 +29,7 @@ module Development.IDE.GHC.ExactPrint
2929
removeComma,
3030
-- * Helper function
3131
eqSrcSpan,
32+
eqSrcSpanA,
3233
epl,
3334
epAnn,
3435
removeTrailingComma,
@@ -690,7 +691,7 @@ eqSrcSpan l r = leftmost_smallest l r == EQ
690691

691692
-- | Equality on SrcSpan's.
692693
-- Ignores the (Maybe BufSpan) field of SrcSpan's.
693-
eqSrcSpanA :: SrcAnn la -> SrcAnn b -> Bool
694+
eqSrcSpanA :: SrcAnn a -> SrcAnn b -> Bool
694695
eqSrcSpanA l r = leftmost_smallest (locA l) (locA r) == EQ
695696

696697
addParensToCtxt :: Maybe EpaLocation -> AnnContext -> AnnContext

‎plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs

Lines changed: 2 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -40,7 +40,6 @@ import Data.Ord (comparing)
4040
import qualified Data.Set as S
4141
import qualified Data.Text as T
4242
import qualified Data.Text.Encoding as T
43-
import qualified Data.Text.Utf16.Rope as Rope
4443
import Development.IDE.Core.Rules
4544
import Development.IDE.Core.RuleTypes
4645
import Development.IDE.Core.Service
@@ -102,8 +101,7 @@ import Language.LSP.Protocol.Types (ApplyWorkspa
102101
type (|?) (InL, InR),
103102
uriToFilePath)
104103
import qualified Language.LSP.Server as LSP
105-
import Language.LSP.VFS (VirtualFile,
106-
virtualFileText)
104+
import Language.LSP.VFS (virtualFileText)
107105
import qualified Text.Fuzzy.Parallel as TFP
108106
import qualified Text.Regex.Applicative as RE
109107
import Text.Regex.TDFA ((=~), (=~~))
@@ -389,7 +387,6 @@ suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range}
389387
findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs)
390388
findImportDeclByModuleName decls modName = flip find decls $ \case
391389
(L _ ImportDecl {..}) -> modName == moduleNameString (unLoc ideclName)
392-
_ -> error "impossible"
393390

394391
isTheSameLine :: SrcSpan -> SrcSpan -> Bool
395392
isTheSameLine s1 s2
@@ -637,7 +634,7 @@ suggestDeleteUnusedBinding
637634
case grhssLocalBinds of
638635
(HsValBinds _ (ValBinds _ bag lsigs)) -> go bag lsigs
639636
_ -> []
640-
findRelatedSpanForMatch _ _ _ = []
637+
-- findRelatedSpanForMatch _ _ _ = []
641638

642639
findRelatedSpanForHsBind
643640
:: PositionIndexedString
@@ -1123,8 +1120,6 @@ targetModuleName :: ModuleTarget -> ModuleName
11231120
targetModuleName ImplicitPrelude{} = mkModuleName "Prelude"
11241121
targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) =
11251122
unLoc ideclName
1126-
targetModuleName (ExistingImp _) =
1127-
error "Cannot happen!"
11281123

11291124
disambiguateSymbol ::
11301125
Annotated ParsedSource ->

‎plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs

Lines changed: 8 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ import Control.Monad.Reader
1919
import Control.Monad.Trans.Maybe
2020
import Data.Either (fromRight,
2121
partitionEithers)
22+
import Data.Functor ((<&>))
2223
import Data.IORef.Extra
2324
import qualified Data.Map as Map
2425
import Data.Maybe (fromMaybe)
@@ -52,7 +53,6 @@ type GhcideCodeAction = ExceptT PluginError (ReaderT CodeActionArgs IO) GhcideCo
5253

5354
-------------------------------------------------------------------------------------------------
5455

55-
{-# ANN runGhcideCodeAction ("HLint: ignore Move guards forward" :: String) #-}
5656
runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams Method_TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult
5757
runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = diags}) codeAction = do
5858
let mbFile = toNormalizedFilePath' <$> uriToFilePath uri
@@ -70,28 +70,26 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra
7070
caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments
7171
caaContents <-
7272
onceIO $
73-
runRule GetFileContents >>= \case
74-
Just (_, txt) -> pure txt
75-
_ -> pure Nothing
73+
runRule GetFileContents <&> \case
74+
Just (_, txt) -> txt
75+
Nothing -> Nothing
7676
caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule
7777
caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource
7878
caaTmr <- onceIO $ runRule TypeCheck
7979
caaHar <- onceIO $ runRule GetHieAst
8080
caaBindings <- onceIO $ runRule GetBindings
8181
caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs
8282
results <- liftIO $
83-
8483
sequence
85-
[ runReaderT (runExceptT codeAction) caa
86-
| caaDiagnostic <- diags,
87-
let caa = CodeActionArgs {..}
84+
[ runReaderT (runExceptT codeAction) CodeActionArgs {..}
85+
| caaDiagnostic <- diags
8886
]
89-
let (errs, successes) = partitionEithers results
87+
let (_errs, successes) = partitionEithers results
9088
pure $ concat successes
9189

9290
mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction)
9391
mkCA title kind isPreferred diags edit =
94-
InR $ CodeAction title kind (Just $ diags) isPreferred Nothing (Just edit) Nothing Nothing
92+
InR $ CodeAction title kind (Just diags) isPreferred Nothing (Just edit) Nothing Nothing
9593

9694
mkGhcideCAPlugin :: GhcideCodeAction -> PluginId -> T.Text -> PluginDescriptor IdeState
9795
mkGhcideCAPlugin codeAction plId desc =

‎plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs

Lines changed: 8 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -82,7 +82,7 @@ rewriteToEdit :: HasCallStack =>
8282
Either String [TextEdit]
8383
rewriteToEdit dflags
8484
(Rewrite dst f) = do
85-
(ast, anns , _) <- runTransformT
85+
(ast, _ , _) <- runTransformT
8686
$ do
8787
ast <- f dflags
8888
pure $ traceAst "REWRITE_result" $ resetEntryDP ast
@@ -209,10 +209,6 @@ lastMaybe :: [a] -> Maybe a
209209
lastMaybe [] = Nothing
210210
lastMaybe other = Just $ last other
211211

212-
liftMaybe :: String -> Maybe a -> TransformT (Either String) a
213-
liftMaybe _ (Just x) = return x
214-
liftMaybe s _ = TransformT $ lift $ Left s
215-
216212
------------------------------------------------------------------------------
217213
extendImport :: Maybe String -> String -> LImportDecl GhcPs -> Rewrite
218214
extendImport mparent identifier lDecl@(L l _) =
@@ -243,7 +239,7 @@ extendImportTopLevel thing (L l it@ImportDecl{..})
243239
#else
244240
| Just (hide, L l' lies) <- ideclHiding
245241
#endif
246-
, hasSibling <- not $ null lies = do
242+
= do
247243
src <- uniqueSrcSpanT
248244
top <- uniqueSrcSpanT
249245
let rdr = reLocA $ L src $ mkRdrUnqual $ mkVarOcc thing
@@ -312,7 +308,7 @@ extendImportViaParent df parent child (L l it@ImportDecl{..})
312308
where
313309
go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs)
314310
| parent == unIEWrappedName ie = TransformT $ lift . Left $ child <> " already included in " <> parent <> " imports"
315-
go hide l' pre (lAbs@(L ll' (IEThingAbs _ absIE@(L _ ie))) : xs)
311+
go hide l' pre ((L ll' (IEThingAbs _ absIE@(L _ ie))) : xs)
316312
-- ThingAbs ie => ThingWith ie child
317313
| parent == unIEWrappedName ie = do
318314
srcChild <- uniqueSrcSpanT
@@ -353,9 +349,8 @@ extendImportViaParent df parent child (L l it@ImportDecl{..})
353349
#endif
354350
lies = L l' $ reverse pre ++ [L l'' thing] ++ xs
355351
return $ L l it'
356-
| parent == unIEWrappedName ie
357-
, hasSibling <- not $ null lies' =
358-
do
352+
| parent == unIEWrappedName ie = do
353+
let hasSibling = not $ null lies'
359354
srcChild <- uniqueSrcSpanT
360355
let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child
361356
childRdr <- pure $ setEntryDP childRdr $ SameLine $ if hasSibling then 1 else 0
@@ -380,8 +375,7 @@ extendImportViaParent df parent child (L l it@ImportDecl{..})
380375
fixLast = if hasSibling then first addComma else id
381376
return $ L l it'
382377
go hide l' pre (x : xs) = go hide l' (x : pre) xs
383-
go hide l' pre []
384-
| hasSibling <- not $ null pre = do
378+
go hide l' pre [] = do
385379
-- [] => ThingWith parent [child]
386380
l'' <- uniqueSrcSpanT
387381
srcParent <- uniqueSrcSpanT
@@ -440,7 +434,7 @@ addCommaInImportList lies x =
440434
_ -> Nothing
441435
pure $ any isTrailingAnnComma (lann_trailing lastItemAnn)
442436

443-
hasSibling = not . null $ lies
437+
hasSibling = not $ null lies
444438

445439
-- Setup the new item. It should have a preceding whitespace if it has siblings, and a trailing comma if the
446440
-- preceding item already has one.
@@ -480,8 +474,6 @@ hideSymbol symbol lidecl@(L loc ImportDecl{..}) =
480474
Just (True, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides)
481475
Just (False, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl imports
482476
#endif
483-
hideSymbol _ (L _ (XImportDecl _)) =
484-
error "cannot happen"
485477

486478
extendHiding ::
487479
String ->
@@ -534,7 +526,7 @@ deleteFromImport ::
534526
XRec GhcPs [LIE GhcPs] ->
535527
DynFlags ->
536528
TransformT (Either String) (LImportDecl GhcPs)
537-
deleteFromImport (T.pack -> symbol) (L l idecl) llies@(L lieLoc lies) _ = do
529+
deleteFromImport (T.pack -> symbol) (L l idecl) (L lieLoc lies) _ = do
538530
let edited = L lieLoc deletedLies
539531
lidecl' =
540532
L l $

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

Lines changed: 11 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -90,24 +90,27 @@ initializeTests = withResource acquire release tests
9090
testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
9191

9292
che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree
93-
che title getActual expected = testCase title doTest
94-
where
95-
doTest = do
96-
ir <- getInitializeResponse
97-
let Just ExecuteCommandOptions {_commands = commands} = getActual $ innerCaps ir
98-
-- Check if expected exists in commands. Note that commands can arrive in different order.
99-
mapM_ (\e -> any (\o -> T.isSuffixOf e o) commands @? show (expected, show commands)) expected
93+
che title getActual expected = testCase title $ do
94+
ir <- getInitializeResponse
95+
ExecuteCommandOptions {_commands = commands} <- assertJust "ExecuteCommandOptions" $ getActual $ innerCaps ir
96+
-- Check if expected exists in commands. Note that commands can arrive in different order.
97+
mapM_ (\e -> any (\o -> T.isSuffixOf e o) commands @? show (expected, show commands)) expected
10098

10199
acquire :: IO (TResponseMessage Method_Initialize)
102100
acquire = run initializeResponse
103101

104102
release :: TResponseMessage Method_Initialize -> IO ()
105-
release = const $ pure ()
103+
release = mempty
106104

107105
innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities
108106
innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c
109107
innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error"
110108

109+
assertJust :: String -> Maybe a -> IO a
110+
assertJust s = \case
111+
Nothing -> assertFailure $ "Expecting Just " <> s <> ", got Nothing"
112+
Just x -> pure x
113+
111114
completionTests :: TestTree
112115
completionTests =
113116
testGroup "auto import snippets"

0 commit comments

Comments
 (0)