Skip to content

Commit

Permalink
Fix ghc and hlint warnings
Browse files Browse the repository at this point in the history
  • Loading branch information
jhrcek committed Apr 14, 2024
1 parent eab156c commit 8c4081b
Show file tree
Hide file tree
Showing 13 changed files with 31 additions and 49 deletions.
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

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

0 comments on commit 8c4081b

Please sign in to comment.