Fix HLint (#544)

Looks like the new version of hlint has a couple of new hints.

changelog_begin
changelog_end

Author: cocreature

.gitignore

@@ -6,3 +6,4 @@ cabal.project.local
 *.lock
 /.tasty-rerun-log
 .vscode
+/.hlint-*

.hlint.yaml

@@ -79,9 +79,11 @@
     - Development.IDE.Compat
     - Development.IDE.Core.FileStore
     - Development.IDE.Core.Compile
+    - Development.IDE.Core.Rules
     - Development.IDE.GHC.Compat
     - Development.IDE.GHC.Util
     - Development.IDE.Import.FindImports
+    - Development.IDE.LSP.Outline
     - Development.IDE.Spans.Calculate
     - Development.IDE.Spans.Documentation
     - Development.IDE.Spans.Common

src/Development/IDE/Core/Compile.hs

@@ -119,7 +119,7 @@ typecheckModule :: IdeDefer
                 -> ParsedModule
                 -> IO (IdeResult (HscEnv, TcModuleResult))
 typecheckModule (IdeDefer defer) hsc depsIn pm = do
-    fmap (either (, Nothing) (second Just) . fmap sequence . sequence) $
+    fmap (either (, Nothing) (second Just . sequence) . sequence) $
       runGhcEnv hsc $
       catchSrcErrors "typecheck" $ do
         -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.

src/Development/IDE/Core/Rules.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE PatternSynonyms       #-}
 #include "ghc-api-version.h"
 
 -- | A Shake implementation of the compiler service, built
@@ -150,7 +149,7 @@ getHomeHieFile f = do
   unless isUpToDate $
        void $ use_ TypeCheck f
 
-  hf <- liftIO $ if isUpToDate then Just <$> loadHieFile hie_f else pure Nothing
+  hf <- liftIO $ whenMaybe isUpToDate (loadHieFile hie_f)
   return ([], hf)
 
 getPackageHieFile :: Module             -- ^ Package Module to load .hie file for
@@ -259,7 +258,7 @@ rawDependencyInformation f = do
     let initialArtifact = ArtifactsLocation f (ModLocation (Just $ fromNormalizedFilePath f) "" "") False
         (initialId, initialMap) = getPathId initialArtifact emptyPathIdMap
     (rdi, ss) <- go (IntSet.singleton $ getFilePathId initialId)
-                    ((RawDependencyInformation IntMap.empty initialMap IntMap.empty), IntMap.empty)
+                    (RawDependencyInformation IntMap.empty initialMap IntMap.empty, IntMap.empty)
     let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss
     return (rdi { rawBootMap = bm })
   where

src/Development/IDE/Core/Shake.hs

@@ -239,7 +239,6 @@ shakeRunDatabaseProfile mbProfileDir shakeDb acts = do
                 shakeProfileDatabase shakeDb $ dir </> file
                 return (dir </> file)
         return (res, proFile)
-    where
 
 {-# NOINLINE profileStartTime #-}
 profileStartTime :: String
@@ -393,6 +392,8 @@ withMVar' var unmasked masked = mask $ \restore -> do
     pure c
 
 -- | Spawn immediately. If you are already inside a call to shakeRun that will be aborted with an exception.
+{- HLINT ignore shakeRun "Redundant bracket" -}
+-- HLint seems to get confused by type applications and suggests to remove parentheses.
 shakeRun :: IdeState -> [Action a] -> IO (IO [a])
 shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =
     withMVar'
@@ -532,7 +533,7 @@ usesWithStale :: IdeRule k v
     => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
 usesWithStale key files = do
     values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
-    mapM (uncurry lastValue) (zip files values)
+    zipWithM lastValue files values
 
 
 withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b
@@ -561,9 +562,9 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old
             Just res -> return res
             Nothing -> do
                 (bs, (diags, res)) <- actionCatch
-                    (do v <- op key file; liftIO $ evaluate $ force $ v) $
+                    (do v <- op key file; liftIO $ evaluate $ force v) $
                     \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
-                modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file
+                modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file
                 (bs, res) <- case res of
                     Nothing -> do
                         staleV <- liftIO $ getValues state key file
@@ -573,7 +574,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old
                                 Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
                                 Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
                                 Failed -> (toShakeValue ShakeResult bs, Failed)
-                    Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
+                    Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
                 liftIO $ setValues state key file res
                 updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
                 let eq = case (bs, fmap decodeShakeValue old) of
@@ -700,7 +701,7 @@ updateFileDiagnostics ::
   -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
   -> Action ()
 updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
-    modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp
+    modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp
     let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
     mask_ $ do
         -- Mask async exceptions to ensure that updated diagnostics are always
@@ -713,7 +714,7 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published
             let newDiags = getFileDiagnostics fp newDiagsStore
             _ <- evaluate newDiagsStore
             _ <- evaluate newDiags
-            pure $! (newDiagsStore, newDiags)
+            pure (newDiagsStore, newDiags)
         modifyVar_ hiddenDiagnostics $ \old -> do
             let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
                                   (T.pack $ show k) (map snd currentHidden) old

src/Development/IDE/LSP/Outline.hs

@@ -43,7 +43,7 @@ moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentI
       mb_decls <- runAction ideState $ use GetParsedModule fp
       pure $ Right $ case mb_decls of
         Nothing -> DSDocumentSymbols (List [])
-        Just (ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } })
+        Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }
           -> let
                declSymbols  = mapMaybe documentSymbolForDecl hsmodDecls
                moduleSymbol = hsmodName <&> \(L l m) ->
@@ -118,17 +118,17 @@ documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just
                                           , _kind           = SkTypeParameter
                                           , _selectionRange = srcSpanToRange l'
                                           }
-documentSymbolForDecl (L l (InstD (ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })))
+documentSymbolForDecl (L l (InstD ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))
   = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty
                                                  , _kind = SkInterface
                                                  }
-documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))
+documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))
   = Just (defDocumentSymbol l :: DocumentSymbol)
     { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords
                 (map pprText feqn_pats)
     , _kind = SkInterface
     }
-documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))
+documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))
   = Just (defDocumentSymbol l :: DocumentSymbol)
     { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords
                 (map pprText feqn_pats)

src/Development/IDE/Plugin/Completions/Logic.hs

@@ -11,7 +11,7 @@ module Development.IDE.Plugin.Completions.Logic (
 import Control.Applicative
 import Data.Char (isSpace, isUpper)
 import Data.Generics
-import Data.List as List hiding (stripPrefix)
+import Data.List.Extra as List hiding (stripPrefix)
 import qualified Data.Map  as Map
 import Data.Maybe (fromMaybe, mapMaybe)
 import qualified Data.Text as T
@@ -162,7 +162,7 @@ getArgText typ = argText
   where
     argTypes = getArgs typ
     argText :: T.Text
-    argText =  mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes
+    argText =  mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes
     snippet :: Int -> Type -> T.Text
     snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"
     getArgs :: Type -> [Type]

test/exe/Main.hs

@@ -14,9 +14,8 @@ import Control.Exception (catch)
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
 import Data.Aeson (FromJSON, Value)
-import Data.Char (toLower)
 import Data.Foldable
-import Data.List
+import Data.List.Extra
 import Data.Rope.UTF16 (Rope)
 import qualified Data.Rope.UTF16 as Rope
 import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
@@ -129,8 +128,8 @@ initializeResponseTests = withResource acquire release tests where
         where
             doTest = do
                 ir <- getInitializeResponse
-                let Just (ExecuteCommandOptions {_commands = List [command]}) = getActual $ innerCaps ir
-                True @=? (T.isSuffixOf "typesignature.add" command)
+                let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir
+                True @=? T.isSuffixOf "typesignature.add" command
 
 
   innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
@@ -401,14 +400,14 @@ diagnosticTests = testGroup "diagnostics"
           Just pathB <- pure $ uriToFilePath uriB
           uriB <- pure $
               let (drive, suffix) = splitDrive pathB
-              in filePathToUri (joinDrive (map toLower drive ) suffix)
+              in filePathToUri (joinDrive (lower drive) suffix)
           liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
           liftIO $ writeFileUTF8 pathB $ T.unpack bContent
           uriA <- getDocUri "A/A.hs"
           Just pathA <- pure $ uriToFilePath uriA
           uriA <- pure $
               let (drive, suffix) = splitDrive pathA
-              in filePathToUri (joinDrive (map toLower drive ) suffix)
+              in filePathToUri (joinDrive (lower drive) suffix)
           let itemA = TextDocumentItem uriA "haskell" 0 aContent
           let a = TextDocumentIdentifier uriA
           sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
@@ -459,7 +458,7 @@ codeLensesTests = testGroup "code lenses"
 watchedFilesTests :: TestTree
 watchedFilesTests = testGroup "watched files"
   [ testSession' "workspace files" $ \sessionDir -> do
-      liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-isrc\"]}}"
+      liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"
       _doc <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
       watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
 
@@ -473,7 +472,7 @@ watchedFilesTests = testGroup "watched files"
       liftIO $ length watchedFileRegs @?= 6
 
   , testSession' "non workspace file" $ \sessionDir -> do
-      liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
+      liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
       _doc <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
       watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
 
@@ -980,14 +979,15 @@ suggestImportTests = testGroup "suggest import actions"
       let defLine = length imps + 1
           range = Range (Position defLine 0) (Position defLine maxBound)
       actions <- getCodeActions doc range
-      case wanted of
-        False ->
-          liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
-        True -> do
-          action <- liftIO $ pickActionWithTitle newImp actions
-          executeCodeAction action
-          contentAfterAction <- documentContents doc
-          liftIO $ after @=? contentAfterAction
+      if wanted
+         then do
+             action <- liftIO $ pickActionWithTitle newImp actions
+             executeCodeAction action
+             contentAfterAction <- documentContents doc
+             liftIO $ after @=? contentAfterAction
+          else
+              liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
+
 
 addExtensionTests :: TestTree
 addExtensionTests = testGroup "add language extension actions"
@@ -1984,6 +1984,8 @@ cradleTests = testGroup "cradle"
     ,testGroup "loading" [loadCradleOnlyonce]
     ]
 
+{- HLINT ignore loadCradleOnlyonce "Redundant bracket" -}
+-- HLint seems to get confused by type applications and suggests to remove parentheses.
 loadCradleOnlyonce :: TestTree
 loadCradleOnlyonce = testGroup "load cradle only once"
     [ testSession' "implicit" implicit
@@ -2351,11 +2353,13 @@ nthLine i r
     | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
     | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
 
+{- HLINT ignore getWatchedFilesSubscriptionsUntil "Redundant bracket" -}
+-- HLint seems to get confused by type applications and suggests to remove parentheses.
 getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]
 getWatchedFilesSubscriptionsUntil = do
       msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)
       return
             [ args
-            | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs
+            | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
             , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
             ]