Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Fix ghc and hlint warnings #568

Merged
merged 5 commits into from
Apr 16, 2024
Merged
Show file tree
Hide file tree
Changes from 1 commit
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 4 additions & 1 deletion cabal.project
Original file line number Diff line number Diff line change
Expand Up @@ -10,12 +10,15 @@ test-show-details: direct

benchmarks: True

package *
ghc-options: -Wunused-packages
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Hmm. I think we normally put warning options in the cabal files, can we do that here too? Putting them all in cabal.project wouldn't be totally unreasonable, it's just inconsistent.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I was just lazy 😄
But I agree and I moved it to cabal files + slightly consolidating using common warnings stanza and fixed few more warnings.
I hope there's nothing controversial, but will wait few days for your feedback (or let you merge if you think it's ok).


package lsp
flags: +demo

package lsp-types
-- This makes a big difference here as lsp-types
-- has very many independent modules
-- has very many independent modules
ghc-options: -j4

-- We allow filepath-1.5, this lets us actually test it. There is no problem
Expand Down
1 change: 0 additions & 1 deletion lsp-test/lsp-test.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -66,7 +66,6 @@ library
, mtl >=2.2 && <2.4
, parser-combinators ^>=1.3
, process ^>=1.6
, row-types ^>=1.0
, some ^>=1.0
, text >=1 && <2.2
, time >=1.10 && <1.13
Expand Down
3 changes: 1 addition & 2 deletions lsp-test/src/Language/LSP/Test/Compat.hs
Original file line number Diff line number Diff line change
@@ -1,7 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
-- For some reason ghc warns about not using
-- Control.Monad.IO.Class but it's needed for
Expand Down Expand Up @@ -103,7 +102,7 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do
return ()
where ignoreSigPipe = ignoreIOError ResourceVanished ePIPE
ignorePermDenied = ignoreIOError PermissionDenied eACCES

ignoreIOError :: IOErrorType -> Errno -> IO () -> IO ()
ignoreIOError ioErrorType errno =
C.handle $ \e -> case e of
Expand Down
3 changes: 1 addition & 2 deletions lsp-test/src/Language/LSP/Test/Decoding.hs
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,6 @@ import Data.Aeson
import Data.Aeson.Types
import Data.ByteString.Lazy.Char8 qualified as B
import Data.Foldable
import Data.Functor.Const
import Data.Functor.Product
import Data.Maybe
import Language.LSP.Protocol.Lens qualified as L
Expand Down Expand Up @@ -82,7 +81,7 @@ decodeFromServerMsg reqMap bytes = unP $ parse p obj
let (mm, newMap) = pickFromIxMap lid reqMap
in case mm of
Nothing -> Nothing
Just m -> Just $ (m, Pair m (Const newMap))
Just m -> Just (m, Pair m (Const newMap))
unP (Success (FromServerMess m msg)) = (reqMap, FromServerMess m msg)
unP (Success (FromServerRsp (Pair m (Const newMap)) msg)) = (newMap, FromServerRsp m msg)
unP (Error e) = error $ "Error decoding " <> show obj <> " :" <> e
Expand Down
11 changes: 3 additions & 8 deletions lsp-test/src/Language/LSP/Test/Files.hs
Original file line number Diff line number Diff line change
Expand Up @@ -83,18 +83,13 @@ mapUris f event =
swapDocumentChangeUri (InR (InR (InL renameFile))) = InR $ InR $ InL $ L.newUri .~ f (renameFile ^. L.newUri) $ renameFile
swapDocumentChangeUri (InR (InR (InR deleteFile))) = InR $ InR $ InR $ swapUri id deleteFile
in e
& L.changes . _Just %~ swapKeys f
& L.changes . _Just %~ M.mapKeys f
& L.documentChanges . _Just . traversed %~ swapDocumentChangeUri

swapKeys :: (Uri -> Uri) -> M.Map Uri b -> M.Map Uri b
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The only non-mechanical change, I just noticed and couldn't resist the simplifcation 😃

swapKeys f = M.foldlWithKey' (\acc k v -> M.insert (f k) v acc) M.empty

swapUri :: L.HasUri b Uri => Lens' a b -> a -> a
swapUri lens x =
let newUri = f (x ^. lens . L.uri)
in (lens . L.uri) .~ newUri $ x
swapUri lens = (lens . L.uri) %~ f

-- \| Transforms rootUri/rootPath.
-- Transforms rootUri/rootPath.
transformInit :: InitializeParams -> InitializeParams
transformInit x =
let modifyRootPath p =
Expand Down
24 changes: 12 additions & 12 deletions lsp-test/src/Language/LSP/Test/Session.hs
Original file line number Diff line number Diff line change
Expand Up @@ -118,13 +118,13 @@ data SessionConfig = SessionConfig
-- with a 'mylang' key whose value is the actual config for the server. You
-- can also include other config sections if your server may request those.
, ignoreLogNotifications :: Bool
-- ^ Whether or not to ignore @window/showMessage@ and @window/logMessage@ notifications
-- ^ Whether or not to ignore @window/showMessage@ and @window/logMessage@ notifications
-- from the server, defaults to True.
, ignoreConfigurationRequests :: Bool
-- ^ Whether or not to ignore @workspace/configuration@ requests from the server,
-- defaults to True.
, ignoreRegistrationRequests :: Bool
-- ^ Whether or not to ignore @client/registerCapability@ and @client/unregisterCapability@
-- ^ Whether or not to ignore @client/registerCapability@ and @client/unregisterCapability@
-- requests from the server, defaults to True.
, initialWorkspaceFolders :: Maybe [WorkspaceFolder]
-- ^ The initial workspace folders to send in the @initialize@ request.
Expand Down Expand Up @@ -247,7 +247,7 @@ runSessionMonad context state (Session session) = runReaderT (runStateT conduit
curId <- getCurTimeoutId
case msg of
ServerMessage sMsg -> yield sMsg
TimeoutMessage tId -> when (curId == tId) $ lastReceivedMessage <$> get >>= throw . Timeout
TimeoutMessage tId -> when (curId == tId) $ get >>= throw . Timeout . lastReceivedMessage

-- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
-- It also does not automatically send initialize and exit messages.
Expand Down Expand Up @@ -338,7 +338,7 @@ updateStateC = awaitForever $ \msg -> do
let requestedSections = mapMaybe (\i -> i ^? L.section . _Just) $ r ^. L.params . L.items
let o = curLspConfig state
-- check for each requested section whether we have it
let configsOrErrs = (flip fmap) requestedSections $ \section ->
let configsOrErrs = flip fmap requestedSections $ \section ->
case o ^. at (fromString $ T.unpack section) of
Just config -> Right config
Nothing -> Left section
Expand All @@ -347,9 +347,9 @@ updateStateC = awaitForever $ \msg -> do

-- we have to return exactly the number of sections requested, so if we can't find all of them then that's an error
sendMessage $ TResponseMessage "2.0" (Just $ r ^. L.id) $
if null errs
then (Right configs)
else Left $ ResponseError (InL LSPErrorCodes_RequestFailed) ("No configuration for requested sections: " <> (T.pack $ show errs)) Nothing
if null errs
then Right configs
else Left $ ResponseError (InL LSPErrorCodes_RequestFailed) ("No configuration for requested sections: " <> T.pack (show errs)) Nothing
_ -> pure ()
unless (
(ignoringLogNotifications state && isLogNotification msg)
Expand Down Expand Up @@ -414,7 +414,7 @@ updateState (FromServerMess SMethod_WorkspaceApplyEdit r) = do

-- First, prefer the versioned documentChanges field
allChangeParams <- case r ^. L.params . L.edit . L.documentChanges of
Just (cs) -> do
Just cs -> do
mapM_ (checkIfNeedsOpened . documentChangeUri) cs
-- replace the user provided version numbers with the VFS ones + 1
-- (technically we should check that the user versions match the VFS ones)
Expand Down Expand Up @@ -472,8 +472,8 @@ updateState (FromServerMess SMethod_WorkspaceApplyEdit r) = do

-- TODO: move somewhere reusable
editToChangeEvent :: TextEdit |? AnnotatedTextEdit -> TextDocumentContentChangeEvent
editToChangeEvent (InR e) = TextDocumentContentChangeEvent $ InL $ TextDocumentContentChangePartial { _range = (e ^. L.range) , _rangeLength = Nothing , _text = (e ^. L.newText) }
editToChangeEvent (InL e) = TextDocumentContentChangeEvent $ InL $ TextDocumentContentChangePartial { _range = (e ^. L.range) , _rangeLength = Nothing , _text = (e ^. L.newText) }
editToChangeEvent (InR e) = TextDocumentContentChangeEvent $ InL $ TextDocumentContentChangePartial { _range = e ^. L.range , _rangeLength = Nothing , _text = e ^. L.newText }
editToChangeEvent (InL e) = TextDocumentContentChangeEvent $ InL $ TextDocumentContentChangePartial { _range = e ^. L.range , _rangeLength = Nothing , _text = e ^. L.newText }

getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams
getParamsFromDocumentChange (InL textDocumentEdit) = getParamsFromTextDocumentEdit textDocumentEdit
Expand All @@ -491,11 +491,11 @@ updateState (FromServerMess SMethod_WorkspaceApplyEdit r) = do

textDocumentEdits uri edits = do
vers <- textDocumentVersions uri
pure $ map (\(v, e) -> TextDocumentEdit (review _versionedTextDocumentIdentifier v) [InL e]) $ zip vers edits
pure $ zipWith (\v e -> TextDocumentEdit (review _versionedTextDocumentIdentifier v) [InL e]) vers edits

getChangeParams uri edits = do
edits <- textDocumentEdits uri (reverse edits)
pure $ catMaybes $ map getParamsFromTextDocumentEdit edits
pure $ mapMaybe getParamsFromTextDocumentEdit edits

mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
mergeParams params = let events = concat (toList (map (toList . (^. L.contentChanges)) params))
Expand Down
5 changes: 0 additions & 5 deletions lsp-types/lsp-types.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -67,12 +67,10 @@ library
, deepseq >=1.4 && <1.6
, Diff >=0.4 && <0.6
, dlist ^>=1.0
, exceptions ^>=0.10
, hashable ^>=1.4
, indexed-traversable ^>=0.1
, indexed-traversable-instances ^>=0.1
, lens >=5.1 && <5.3
, lens-aeson ^>=1.2
, mod ^>=0.2
, mtl >=2.2 && <2.4
, network-uri ^>=2.6
Expand Down Expand Up @@ -600,15 +598,13 @@ library lsp-types-quickcheck
Language.LSP.Protocol.QuickCheck.Types

build-depends:
, aeson >=2
, base >=4.11 && <5
, lsp-types
, row-types
, QuickCheck
, quickcheck-instances
, generic-arbitrary
, template-haskell
, text >=1 && <2.2

executable generator
hs-source-dirs: generator
Expand Down Expand Up @@ -659,7 +655,6 @@ test-suite lsp-types-test
, network-uri
, QuickCheck
, quickcheck-instances
, row-types
, text

build-tool-depends: hspec-discover:hspec-discover
2 changes: 0 additions & 2 deletions lsp/lsp.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -68,7 +68,6 @@ library
, mtl >=2.2 && <2.4
, prettyprinter ^>=1.7
, random ^>=1.2
, row-types ^>=1.0
, sorted-list ^>=0.2.1
, stm ^>=2.5
, text >=1 && <2.2
Expand Down Expand Up @@ -129,7 +128,6 @@ test-suite lsp-test
, containers
, hspec
, lsp
, row-types
, sorted-list
, text
, text-rope
Expand Down
2 changes: 1 addition & 1 deletion lsp/src/Language/LSP/Diagnostics.hs
Original file line number Diff line number Diff line change
Expand Up @@ -50,7 +50,7 @@ type DiagnosticsBySource = Map.Map (Maybe Text) (SL.SortedList J.Diagnostic)
-- ---------------------------------------------------------------------

partitionBySource :: [J.Diagnostic] -> DiagnosticsBySource
partitionBySource diags = Map.fromListWith mappend $ map (\d -> (J._source d, (SL.singleton d))) diags
partitionBySource diags = Map.fromListWith mappend $ map (\d -> (J._source d, SL.singleton d)) diags

-- ---------------------------------------------------------------------

Expand Down
5 changes: 2 additions & 3 deletions lsp/src/Language/LSP/Server/Control.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,3 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.LSP.Server.Control (
Expand Down Expand Up @@ -180,9 +179,9 @@ ioLoop ioLogger logger clientIn serverDefinition vfs sendMsg = do
go (parse parser remainder)

parser = do
try contentType <|> (return ())
try contentType <|> return ()
len <- contentLength
try contentType <|> (return ())
try contentType <|> return ()
_ <- string _ONE_CRLF
Attoparsec.take len

Expand Down
7 changes: 3 additions & 4 deletions lsp/src/Language/LSP/Server/Core.hs
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,6 @@ import Colog.Core (
import Control.Applicative
import Control.Concurrent.Async
import Control.Concurrent.Extra as C
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.Exception qualified as E
import Control.Lens (at, (^.), (^?), _Just)
Expand Down Expand Up @@ -88,7 +87,7 @@ deriving instance (Show LspCoreLog)

instance Pretty LspCoreLog where
pretty (NewConfig config) = "LSP: set new config:" <+> prettyJSON config
pretty (ConfigurationNotSupported) = "LSP: not requesting configuration since the client does not support workspace/configuration"
pretty ConfigurationNotSupported = "LSP: not requesting configuration since the client does not support workspace/configuration"
pretty (ConfigurationParseError settings err) =
vsep
[ "LSP: configuration parse error:"
Expand All @@ -97,7 +96,7 @@ instance Pretty LspCoreLog where
, prettyJSON settings
]
pretty (BadConfigurationResponse err) = "LSP: error when requesting configuration: " <+> pretty err
pretty (WrongConfigSections sections) = "LSP: expected only one configuration section, got: " <+> (prettyJSON $ J.toJSON sections)
pretty (WrongConfigSections sections) = "LSP: expected only one configuration section, got: " <+> prettyJSON (J.toJSON sections)
pretty (CantRegister m) = "LSP: can't register dynamically for:" <+> pretty m

newtype LspT config m a = LspT {unLspT :: ReaderT (LanguageContextEnv config) m a}
Expand Down Expand Up @@ -612,7 +611,7 @@ trySendRegistration logger method regOpts = do

pure (Just $ RegistrationToken method regId)
else do
logger <& (CantRegister SMethod_WorkspaceDidChangeConfiguration) `WithSeverity` Warning
logger <& CantRegister SMethod_WorkspaceDidChangeConfiguration `WithSeverity` Warning
pure Nothing

{- | Sends a @client/unregisterCapability@ request and removes the handler
Expand Down
10 changes: 4 additions & 6 deletions lsp/src/Language/LSP/Server/Processing.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,4 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
Expand Down Expand Up @@ -47,7 +46,6 @@ import Data.IxMap
import Data.List
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict qualified as Map
import Data.Monoid
import Data.String (fromString)
import Data.Text qualified as T
import Data.Text.Lazy.Encoding qualified as TL
Expand Down Expand Up @@ -127,7 +125,7 @@ initializeRequestHandler logger ServerDefinition{..} vfs sendFunc req = do
sendResp $ makeResponseError (req ^. L.id) err
pure Nothing
handleErr (Right a) = pure $ Just a
flip E.catch (initializeErrorHandler $ sendResp . makeResponseError (req ^. L.id)) $ handleErr <=< runExceptT $ mdo
E.handle (initializeErrorHandler $ sendResp . makeResponseError (req ^. L.id)) $ handleErr <=< runExceptT $ mdo
let p = req ^. L.params
rootDir =
getFirst $
Expand All @@ -136,7 +134,7 @@ initializeRequestHandler logger ServerDefinition{..} vfs sendFunc req = do
[ p ^? L.rootUri . _L >>= uriToFilePath
, p ^? L.rootPath . _Just . _L <&> T.unpack
]
clientCaps = (p ^. L.capabilities)
clientCaps = p ^. L.capabilities

let initialWfs = case p ^. L.workspaceFolders of
Just (InL xs) -> xs
Expand All @@ -148,11 +146,11 @@ initializeRequestHandler logger ServerDefinition{..} vfs sendFunc req = do
initialConfig <- case configObject of
Just o -> case parseConfig defaultConfig o of
Right newConfig -> do
liftIO $ logger <& (LspCore $ NewConfig o) `WithSeverity` Debug
liftIO $ logger <& LspCore (NewConfig o) `WithSeverity` Debug
pure newConfig
Left err -> do
-- Warn not error here, since initializationOptions is pretty unspecified
liftIO $ logger <& (LspCore $ ConfigurationParseError o err) `WithSeverity` Warning
liftIO $ logger <& LspCore (ConfigurationParseError o err) `WithSeverity` Warning
pure defaultConfig
Nothing -> pure defaultConfig

Expand Down
2 changes: 0 additions & 2 deletions lsp/test/VspSpec.hs
Original file line number Diff line number Diff line change
@@ -1,10 +1,8 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}

module VspSpec where

import Data.Row
import Data.String
import Data.Text qualified as T
import Data.Text.Utf16.Rope.Mixed qualified as Rope
Expand Down
Loading