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 4 commits
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
2 changes: 1 addition & 1 deletion cabal.project
Original file line number Diff line number Diff line change
Expand Up @@ -15,7 +15,7 @@ package lsp

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/bench/SimpleBench.hs
Original file line number Diff line number Diff line change
@@ -1,7 +1,6 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module Main where

Expand Down
1 change: 1 addition & 0 deletions lsp-test/example/Test.hs
Original file line number Diff line number Diff line change
Expand Up @@ -6,6 +6,7 @@ import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Test

main :: IO ()
main = runSession "lsp-demo-reactor-server" fullCaps "test/data/" $ do
doc <- openDoc "Rename.hs" "haskell"

Expand Down
2 changes: 0 additions & 2 deletions lsp-test/func-test/FuncTest.hs
Original file line number Diff line number Diff line change
Expand Up @@ -15,14 +15,12 @@ import Control.Monad.IO.Class
import Data.Aeson qualified as J
import Data.Maybe
import Data.Proxy
import Data.Set qualified as Set
import Language.LSP.Protocol.Lens qualified as L
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Server
import Language.LSP.Test qualified as Test
import System.Exit
import System.IO
import System.Process
import Test.Hspec
import UnliftIO
Expand Down
12 changes: 9 additions & 3 deletions lsp-test/lsp-test.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -31,7 +31,11 @@ source-repository head
type: git
location: https://github.com/haskell/lsp

common warnings
ghc-options: -Wunused-packages

library
import: warnings
hs-source-dirs: src
default-language: GHC2021
exposed-modules: Language.LSP.Test
Expand Down Expand Up @@ -66,7 +70,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 All @@ -90,6 +93,7 @@ library
ghc-options: -W

test-suite tests
import: warnings
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: Test.hs
Expand All @@ -115,6 +119,7 @@ test-suite tests
, unliftio

test-suite func-test
import: warnings
type: exitcode-stdio-1.0
hs-source-dirs: func-test
default-language: GHC2021
Expand All @@ -123,7 +128,6 @@ test-suite func-test
, base
, aeson
, co-log-core
, containers
, hspec
, lens
, lsp
Expand All @@ -133,6 +137,7 @@ test-suite func-test
, unliftio

test-suite example
import: warnings
type: exitcode-stdio-1.0
hs-source-dirs: example
default-language: GHC2021
Expand All @@ -145,11 +150,12 @@ test-suite example
build-tool-depends: lsp:lsp-demo-reactor-server

benchmark simple-bench
import: warnings
type: exitcode-stdio-1.0
hs-source-dirs: bench
default-language: GHC2021
main-is: SimpleBench.hs
ghc-options: -Wall -O2 -eventlog -rtsopts
ghc-options: -Wall -O2 -rtsopts
build-depends:
, base
, extra
Expand Down
6 changes: 3 additions & 3 deletions lsp-test/src/Language/LSP/Test.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE DataKinds #-}

{- |
Module : Language.LSP.Test
Expand Down Expand Up @@ -559,7 +559,7 @@ createDoc file languageId contents = do
let pred :: SomeRegistration -> [TRegistration Method_WorkspaceDidChangeWatchedFiles]
pred (SomeRegistration r@(TRegistration _ SMethod_WorkspaceDidChangeWatchedFiles _)) = [r]
pred _ = mempty
regs = concatMap pred $ Map.elems dynCaps
regs = concatMap pred dynCaps
watchHits :: FileSystemWatcher -> Bool
watchHits (FileSystemWatcher (GlobPattern (InL (Pattern pattern))) kind) =
-- If WatchKind is excluded, defaults to all true as per spec
Expand Down Expand Up @@ -740,7 +740,7 @@ getCodeActionContext doc = do
Note that this does not wait for more to come in.
-}
getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. L.uri) . curDiagnostics <$> get
getCurrentDiagnostics doc = Map.findWithDefault [] (toNormalizedUri $ doc ^. L.uri) . curDiagnostics <$> get

-- | Returns the tokens of all progress sessions that have started but not yet ended.
getIncompleteProgressSessions :: Session (Set.Set ProgressToken)
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
5 changes: 2 additions & 3 deletions lsp-test/src/Language/LSP/Test/Decoding.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE DataKinds #-}

module Language.LSP.Test.Decoding where

Expand All @@ -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
13 changes: 4 additions & 9 deletions lsp-test/src/Language/LSP/Test/Files.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE DataKinds #-}

module Language.LSP.Test.Files (
swapFiles,
Expand Down 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
2 changes: 1 addition & 1 deletion lsp-test/src/Language/LSP/Test/Parsing.hs
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE DataKinds #-}

module Language.LSP.Test.Parsing (
-- $receiving
Expand Down
26 changes: 13 additions & 13 deletions lsp-test/src/Language/LSP/Test/Session.hs
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE DataKinds #-}

module Language.LSP.Test.Session
( Session(..)
Expand Down 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
2 changes: 1 addition & 1 deletion lsp-test/test/DummyServer.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE DataKinds #-}

module DummyServer where

Expand Down
2 changes: 1 addition & 1 deletion lsp-test/test/Test.hs
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE DataKinds #-}

import Control.Applicative.Combinators
import Control.Concurrent
Expand Down
4 changes: 2 additions & 2 deletions lsp-types/generator/CodeGen.hs
Original file line number Diff line number Diff line change
Expand Up @@ -367,7 +367,7 @@ printStruct tn s@Structure{name, documentation, since, proposed, deprecated} = d
optionalMatcherName <- entityName "Language.LSP.Protocol.Types.Common" ".:!?"
let toJsonD =
let (unzip -> (args, pairEs)) = flip fmap (zip props [0 ..]) $ \(Property{name, optional}, i) ->
let n :: T.Text = "arg" <> (T.pack $ show i)
let n :: T.Text = "arg" <> T.pack (show i)
pairE = case optional of
Just True -> dquotes (pretty name) <+> pretty optionalPairerName <+> pretty n
_ -> brackets (dquotes (pretty name) <+> "Aeson..=" <+> pretty n)
Expand Down Expand Up @@ -485,7 +485,7 @@ printEnum tn Enumeration{name, type_, values, supportsCustomValues, documentatio
let customCon =
let cn = makeConstrName (Just enumName) "Custom"
in if custom then Just (cn, pretty cn <+> ty) else Nothing
let cons = normalCons ++ (fmap snd $ maybeToList customCon)
let cons = normalCons ++ (snd <$> maybeToList customCon)

ensureImport "Data.Aeson" (QualAs "Aeson")
ensureImport "Data.Row.Aeson" (QualAs "Aeson")
Expand Down
Loading
Loading