Fix some hlint warnings (#2523)

* Fix some hlint warnings

* Revert changes in hie-compat

Co-authored-by: Anton Latukha <[email protected]>

Author: jhrcek

ghcide/session-loader/Development/IDE/Session.hs

@@ -467,7 +467,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
     let sessionOpts :: (Maybe FilePath, FilePath)
                     -> IO (IdeResult HscEnvEq, [FilePath])
         sessionOpts (hieYaml, file) = do
-          v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags
+          v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags
           cfp <- makeAbsolute file
           case HM.lookup (toNormalizedFilePath' cfp) v of
             Just (opts, old_di) -> do

ghcide/src/Development/IDE/Import/DependencyInformation.hs

@@ -166,7 +166,7 @@ data ModuleParseError = ModuleParseError
 instance NFData ModuleParseError
 
 -- | Error when trying to locate a module.
-data LocateError = LocateError [Diagnostic]
+newtype LocateError = LocateError [Diagnostic]
   deriving (Eq, Show, Generic)
 
 instance NFData LocateError
@@ -316,7 +316,7 @@ transitiveReverseDependencies file DependencyInformation{..} = do
   where
     go :: Int -> IntSet -> IntSet
     go k i =
-      let outwards = fromMaybe IntSet.empty (IntMap.lookup k depReverseModuleDeps)
+      let outwards = IntMap.findWithDefault IntSet.empty k depReverseModuleDeps
           res = IntSet.union i outwards
           new = IntSet.difference i outwards
       in IntSet.foldr go res new

ghcide/src/Development/IDE/Types/Logger.hs

@@ -31,7 +31,7 @@ data Priority
 -- | Note that this is logging actions _of the program_, not of the user.
 --   You shouldn't call warning/error if the user has caused an error, only
 --   if our code has gone wrong and is itself erroneous (e.g. we threw an exception).
-data Logger = Logger {logPriority :: Priority -> T.Text -> IO ()}
+newtype Logger = Logger {logPriority :: Priority -> T.Text -> IO ()}
 
 instance Semigroup Logger where
     l1 <> l2 = Logger $ \p t -> logPriority l1 p t >> logPriority l2 p t

hls-graph/src/Control/Concurrent/STM/Stats.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE CPP                 #-}
-{-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Control.Concurrent.STM.Stats
     ( atomicallyNamed

hls-graph/src/Development/IDE/Graph.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE PatternSynonyms #-}
-
 module Development.IDE.Graph(
     shakeOptions,
     Rules,

hls-graph/src/Development/IDE/Graph/Internal/Action.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE ConstraintKinds            #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TypeFamilies               #-}
 

hls-graph/src/Development/IDE/Graph/Internal/Database.hs

@@ -4,12 +4,9 @@
 {-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase                 #-}
-{-# LANGUAGE NamedFieldPuns             #-}
 {-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeFamilies               #-}
 
 module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where

hls-graph/src/Development/IDE/Graph/Internal/Options.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE RecordWildCards #-}
-
 module Development.IDE.Graph.Internal.Options where
 
 import           Control.Monad.Trans.Reader

hls-graph/src/Development/IDE/Graph/Internal/Profile.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE CPP             #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ViewPatterns    #-}
 
 {- HLINT ignore "Redundant bracket" -} -- a result of CPP expansion

hls-graph/src/Development/IDE/Graph/Internal/Rules.hs

@@ -1,9 +1,7 @@
 -- We deliberately want to ensure the function we add to the rule database
 -- has the constraints we need on it when we get it out.
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RecordWildCards #-}
 
@@ -44,7 +42,7 @@ addRule f = do
         f2 (Key a) b c = do
             v <- f (fromJust $ cast a :: key) b c
             v <- liftIO $ evaluate v
-            pure $ (Value . toDyn) <$> v
+            pure $ Value . toDyn <$> v
 
 runRule
     :: TheRules -> Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value)

hls-plugin-api/src/Ide/Plugin/Properties.hs

@@ -3,10 +3,8 @@
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE GADTs                 #-}
-{-# LANGUAGE KindSignatures        #-}
 {-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedLabels      #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE ScopedTypeVariables   #-}

hls-plugin-api/src/Ide/PluginUtils.hs

@@ -178,7 +178,7 @@ getClientConfig = getConfig
 getPluginConfig :: MonadLsp Config m => PluginId -> m PluginConfig
 getPluginConfig plugin = do
     config <- getClientConfig
-    return $ flip configForPlugin plugin config
+    return $ configForPlugin config plugin 
 
 -- ---------------------------------------------------------------------
 

hls-plugin-api/src/Ide/Types.hs

@@ -249,7 +249,7 @@ instance PluginMethod TextDocumentCompletion where
   combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs
       where
         limit = maxCompletions conf
-        combine :: [List CompletionItem |? CompletionList] -> ((List CompletionItem) |? CompletionList)
+        combine :: [List CompletionItem |? CompletionList] -> (List CompletionItem |? CompletionList)
         combine cs = go True mempty cs
 
         go !comp acc [] =

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs

@@ -3,11 +3,9 @@
 {-# LANGUAGE ExtendedDefaultRules      #-}
 {-# LANGUAGE FlexibleContexts          #-}
 {-# LANGUAGE FlexibleInstances         #-}
-{-# LANGUAGE LambdaCase                #-}
 {-# LANGUAGE NamedFieldPuns            #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE OverloadedStrings         #-}
-{-# LANGUAGE PatternSynonyms           #-}
 {-# LANGUAGE RankNTypes                #-}
 {-# LANGUAGE RecordWildCards           #-}
 {-# LANGUAGE ScopedTypeVariables       #-}

plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs

@@ -70,7 +70,7 @@ importLensCommand =
   PluginCommand importCommandId "Explicit import command" runImportCommand
 
 -- | The type of the parameters accepted by our command
-data ImportCommandParams = ImportCommandParams WorkspaceEdit
+newtype ImportCommandParams = ImportCommandParams WorkspaceEdit
   deriving (Generic)
   deriving anyclass (FromJSON, ToJSON)
 

plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs

@@ -515,7 +515,7 @@ deriving instance ToJSON RewriteSpec
 data QualName = QualName {qual, name :: String}
   deriving (Eq, Show, Generic, FromJSON, ToJSON)
 
-data IE name
+newtype IE name
   = IEVar name
   deriving (Eq, Show, Generic, FromJSON, ToJSON)
 

plugins/hls-tactics-plugin/src/Refinery/Future.hs

@@ -113,18 +113,18 @@ streamProofs s p = ListT $ go s [] pure p
          -- This would happen when we had a handler that wasn't followed by an error call.
          --     pair >> goal >>= \g -> (handler_ $ \_ -> traceM $ "Handling " <> show g) <|> failure "Error"
          -- We would see the "Handling a" message when solving for b.
-         (go s' (goals ++ [(meta, goal)]) pure $ k h)
+         go s' (goals ++ [(meta, goal)]) pure $ k h
       go s goals handlers (Effect m) = m >>= go s goals handlers
       go s goals handlers (Stateful f) =
           let (s', p) = f s
           in go s' goals handlers p
       go s goals handlers (Alt p1 p2) =
           unListT $ ListT (go s goals handlers p1) <|> ListT (go s goals handlers p2)
       go s goals handlers (Interleave p1 p2) =
-          interleaveT <$> (go s goals handlers p1) <*> (go s goals handlers p2)
+          interleaveT <$> go s goals handlers p1 <*> go s goals handlers p2
       go s goals handlers (Commit p1 p2) = do
           solns <- force =<< go s goals handlers p1
-          if (any isRight solns) then pure $ ofList solns else go s goals handlers p2
+          if any isRight solns then pure $ ofList solns else go s goals handlers p2
       go _ _ _ Empty = pure Done
       go _ _ handlers (Failure err _) = do
           annErr <- handlers err

plugins/hls-tactics-plugin/src/Wingman/AbstractLSP.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE RecordWildCards     #-}
-{-# LANGUAGE StandaloneDeriving  #-}
 
 {-# LANGUAGE NoMonoLocalBinds    #-}
 
@@ -99,7 +98,7 @@ runContinuation plId cont state (fc, b) = do
       res <- c_runCommand cont env args fc b
 
       -- This block returns a maybe error.
-      fmap (maybe (Right $ A.Null) Left . coerce . foldMap Last) $
+      fmap (maybe (Right A.Null) Left . coerce . foldMap Last) $
         for res $ \case
           ErrorMessages errs -> do
             traverse_ showUserFacingMessage errs
@@ -119,7 +118,7 @@ runContinuation plId cont state (fc, b) = do
                   }
               Right edits -> do
                 sendEdits edits
-                pure $ Nothing
+                pure Nothing
 
 
 ------------------------------------------------------------------------------

plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/TacticActions.hs

@@ -161,8 +161,8 @@ graftDecl dflags dst ix make_decl (L src (AMatch (FunRhs (L _ name) _ _) pats _)
   | dst `isSubspanOf` src = do
       L _ dec <- annotateDecl dflags $ make_decl name pats
       case dec of
-        ValD _ (FunBind { fun_matches = MG { mg_alts = L _ alts@(first_match : _)}
-                  }) -> do
+        ValD _ FunBind{ fun_matches = MG { mg_alts = L _ alts@(first_match : _)}
+                      } -> do
           -- For whatever reason, ExactPrint annotates newlines to the ends of
           -- case matches and type signatures, but only allows us to insert
           -- them at the beginning of those things. Thus, we need want to

plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs

@@ -105,5 +105,5 @@ splitToDecl fixity name ams = do
 iterateSplit :: AgdaMatch -> [AgdaMatch]
 iterateSplit am =
   let iterated = iterate (agdaSplit =<<) $ pure am
-   in fmap wildify . head . drop 5 $ iterated
+   in fmap wildify . (!! 5) $ iterated
 

plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE OverloadedLabels  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections     #-}
-{-# LANGUAGE TypeApplications  #-}
 
 module Wingman.CodeGen
   ( module Wingman.CodeGen
@@ -141,8 +140,7 @@ mkDestructPat already_in_scope con names
         in (names', )
          $ ConPatIn (noLoc $ Unqual $ occName $ conLikeName con)
          $ RecCon
-         $ HsRecFields rec_fields
-         $ Nothing
+         $ HsRecFields rec_fields Nothing
   | otherwise =
       (names, ) $ infixifyPatIfNecessary con $
         conP
@@ -208,7 +206,7 @@ patSynExTys ps = patSynExTyVars ps
 
 destruct' :: Bool -> (ConLike -> Judgement -> Rule) -> HyInfo CType -> Judgement -> Rule
 destruct' use_field_puns f hi jdg = do
-  when (isDestructBlacklisted jdg) $ cut -- throwError NoApplicableTactic
+  when (isDestructBlacklisted jdg) cut -- throwError NoApplicableTactic
   let term = hi_name hi
   ext
       <- destructMatches
@@ -227,7 +225,7 @@ destruct' use_field_puns f hi jdg = do
 -- resulting matches.
 destructLambdaCase' :: Bool -> (ConLike -> Judgement -> Rule) -> Judgement -> Rule
 destructLambdaCase' use_field_puns f jdg = do
-  when (isDestructBlacklisted jdg) $ cut -- throwError NoApplicableTactic
+  when (isDestructBlacklisted jdg) cut -- throwError NoApplicableTactic
   let g  = jGoal jdg
   case splitFunTy_maybe (unCType g) of
     Just (arg, _) | isAlgType arg ->
@@ -320,8 +318,7 @@ nonrecLet occjdgs jdg = do
   occexts <- traverse newSubgoal $ fmap snd occjdgs
   ctx     <- ask
   ext     <- newSubgoal
-           $ introduce ctx (userHypothesis $ fmap (second jGoal) occjdgs)
-           $ jdg
+           $ introduce ctx (userHypothesis $ fmap (second jGoal) occjdgs) jdg
   pure $ fmap noLoc $
     let'
       <$> traverse

plugins/hls-tactics-plugin/src/Wingman/Debug.hs

@@ -17,6 +17,7 @@ module Wingman.Debug
 
 import           Control.DeepSeq
 import           Control.Exception
+import           Data.Either (fromRight)
 import qualified Debug.Trace
 import           Development.IDE.GHC.Compat (PlainGhcException, Outputable(..), SDoc, showSDocUnsafe)
 import           System.IO.Unsafe  (unsafePerformIO)
@@ -33,7 +34,7 @@ unsafeRender' sdoc = unsafePerformIO $ do
   -- We might not have unsafeGlobalDynFlags (like during testing), in which
   -- case GHC panics. Instead of crashing, let's just fail to print.
   !res <- try @PlainGhcException $ evaluate $ deepseq z z
-  pure $ either (const "<unsafeRender'>") id res
+  pure $ fromRight "<unsafeRender'>" res
 {-# NOINLINE unsafeRender' #-}
 
 traceMX :: (Monad m, Show a) => String -> a -> m ()

plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs

@@ -17,8 +17,7 @@ import           Data.Maybe
 import           Data.Monoid
 import qualified Data.Text as T
 import           Data.Traversable
-import           Development.IDE (hscEnv)
-import           Development.IDE (realSrcSpanToRange)
+import           Development.IDE (hscEnv, realSrcSpanToRange)
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake (IdeState (..))
 import           Development.IDE.Core.UseStale
@@ -81,7 +80,7 @@ emptyCaseInteraction = Interaction $
           , edits
           )
     )
-  $ (\ _ _ _ we -> pure $ pure $ RawEdit we)
+    (\ _ _ _ we -> pure $ pure $ RawEdit we)
 
 
 scrutinzedType :: EmptyCaseSort Type -> Maybe Type
@@ -115,9 +114,9 @@ graftMatchGroup
     -> Graft (Either String) ParsedSource
 graftMatchGroup ss l =
   hoistGraft (runExcept . runExceptString) $ graftExprWithM ss $ \case
-    L span (HsCase ext scrut mg@_) -> do
+    L span (HsCase ext scrut mg) -> do
       pure $ Just $ L span $ HsCase ext scrut $ mg { mg_alts = l }
-    L span (HsLamCase ext mg@_) -> do
+    L span (HsLamCase ext mg) -> do
       pure $ Just $ L span $ HsLamCase ext $ mg { mg_alts = l }
     (_ :: LHsExpr GhcPs) -> pure Nothing
 
@@ -165,6 +164,6 @@ data EmptyCaseSort a
 emptyCaseQ :: GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
 emptyCaseQ = everything (<>) $ mkQ mempty $ \case
   L new_span (Case scrutinee []) -> pure (new_span, EmptyCase scrutinee)
-  L new_span (expr@(LamCase [])) -> pure (new_span, EmptyLamCase expr)
+  L new_span expr@(LamCase []) -> pure (new_span, EmptyLamCase expr)
   (_ :: LHsExpr GhcTc) -> mempty
 

plugins/hls-tactics-plugin/src/Wingman/GHC.hs

@@ -96,10 +96,7 @@ freshTyvars t = do
             pure (tv, setTyVarUnique tv uniq)
   pure $
     everywhere
-      (mkT $ \tv ->
-        case M.lookup tv reps of
-          Just tv' -> tv'
-          Nothing  -> tv
+      (mkT $ \tv -> M.findWithDefault tv tv reps
       ) $ snd $ tcSplitForAllTyVars t
 
 
@@ -195,7 +192,7 @@ pattern SingleLet bind pats val expr <-
   HsLet _
     (L _ (HsValBinds _
       (ValBinds _ (bagToList ->
-        [(L _ (FunBind _ (L _ bind) (MG _ (L _ [L _ (AMatch _ pats val)]) _) _ _))]) _)))
+        [L _ (FunBind _ (L _ bind) (MG _ (L _ [L _ (AMatch _ pats val)]) _) _ _)]) _)))
     (L _ expr)
 
 
@@ -204,7 +201,7 @@ pattern SingleLet bind pats val expr <-
 pattern Lambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs
 pattern Lambda pats body <-
   HsLam _
-    (MG {mg_alts = L _ [L _ (AMatch _ pats body) ]})
+    MG {mg_alts = L _ [L _ (AMatch _ pats body) ]}
   where
     -- If there are no patterns to bind, just stick in the body
     Lambda [] body   = body
@@ -232,7 +229,7 @@ pattern SinglePatMatch pat body <-
 unpackMatches :: PatCompattable p => [Match p (LHsExpr p)] -> Maybe [(Pat p, LHsExpr p)]
 unpackMatches [] = Just []
 unpackMatches (SinglePatMatch pat body : matches) =
-  (:) <$> pure (pat, body) <*> unpackMatches matches
+  ((pat, body):) <$> unpackMatches matches
 unpackMatches _ = Nothing
 
 
@@ -241,14 +238,14 @@ unpackMatches _ = Nothing
 pattern Case :: PatCompattable p => HsExpr p -> [(Pat p, LHsExpr p)] -> HsExpr p
 pattern Case scrutinee matches <-
   HsCase _ (L _ scrutinee)
-    (MG {mg_alts = L _ (fmap unLoc -> unpackMatches -> Just matches)})
+    MG {mg_alts = L _ (fmap unLoc -> unpackMatches -> Just matches)}
 
 ------------------------------------------------------------------------------
 -- | Like 'Case', but for lambda cases.
 pattern LamCase :: PatCompattable p => [(Pat p, LHsExpr p)] -> HsExpr p
 pattern LamCase matches <-
   HsLamCase _
-    (MG {mg_alts = L _ (fmap unLoc -> unpackMatches -> Just matches)})
+    MG {mg_alts = L _ (fmap unLoc -> unpackMatches -> Just matches)}
 
 
 ------------------------------------------------------------------------------