haskell/haskell-language-server
1
1
Fork 0
mirror of https://github.com/haskell/haskell-language-server.git synced 2024-09-19 04:37:25 +03:00
Code Issues Projects Releases Wiki Activity

Upgrade to new version of lsp libraries (#2494)

Browse Source 
* Update to latest version of lsp libraries

* Compute completions on kick

This is not only for faster completions.
 It's also needed to have semi-fresh completions after editing.
This is specially important for the first completion request of a file - without this change there are no  completions available at all

* Emit LSP custom messages on kick start/finish

useful to synchonize on these events in tests

* Fix completions tests after https://github.com/haskell/lsp/pull/376

* Restore cabal update with comments

* Use new lsp in stack 9.0.1

Co-authored-by: Pepe Iborra <pepeiborra@gmail.com>
Co-authored-by: jneira <atreyu.bbb@gmail.com>
This commit is contained in:
Michael Peyton Jones 2021-12-29 08:45:25 +00:00 committed by GitHub
parent 2fa5994803
commit 7518a3a7eb
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
63 changed files with 332 additions and 264 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.github/workflows/bench.yml vendored
View File

@ -118,6 +118,9 @@ jobs:
${{ env.cache-name }}-${{ runner.os }}-${{ matrix.ghc }}- ${{ env.cache-name }}-${{ runner.os }}-${{ matrix.ghc }}-
${{ env.cache-name }}-${{ runner.os }}- ${{ env.cache-name }}-${{ runner.os }}-
# To ensure we get the lastest hackage index and not relying on haskell action logic
- run: cabal update
# max-backjumps is increased as a temporary solution # max-backjumps is increased as a temporary solution
# for dependency resolution failure # for dependency resolution failure
- run: cabal configure --enable-benchmarks --max-backjumps 12000 - run: cabal configure --enable-benchmarks --max-backjumps 12000

4
.github/workflows/caching.yml vendored
View File

@ -182,6 +182,10 @@ jobs:
${{ env.cache-name }}-${{ runner.os }}-${{ matrix.ghc }}- ${{ env.cache-name }}-${{ runner.os }}-${{ matrix.ghc }}-
${{ env.cache-name }}-${{ runner.os }}- ${{ env.cache-name }}-${{ runner.os }}-
# To ensure we get the lastest hackage index and not relying on haskell action logic
- if: steps.compiled-deps.outputs.cache-hit != 'true'
run: cabal update
- if: steps.compiled-deps.outputs.cache-hit != 'true' && runner.os == 'Linux' && matrix.ghc == '8.10.7' - if: steps.compiled-deps.outputs.cache-hit != 'true' && runner.os == 'Linux' && matrix.ghc == '8.10.7'
name: Download sources for bench name: Download sources for bench
# Downloaded separately, to match the tested work/PR workflow guarantees # Downloaded separately, to match the tested work/PR workflow guarantees

4
.github/workflows/test.yml vendored
View File

@ -179,6 +179,10 @@ jobs:
${{ env.cache-name }}-${{ runner.os }}-${{ matrix.ghc }}- ${{ env.cache-name }}-${{ runner.os }}-${{ matrix.ghc }}-
${{ env.cache-name }}-${{ runner.os }}- ${{ env.cache-name }}-${{ runner.os }}-
# To ensure we get the lastest hackage index and not relying on haskell action logic
- if: steps.compiled-deps.outputs.cache-hit != 'true'
run: cabal update
# repeating builds to workaround segfaults in windows and ghc-8.8.4 # repeating builds to workaround segfaults in windows and ghc-8.8.4
- name: Build - name: Build
run: cabal build || cabal build || cabal build run: cabal build || cabal build || cabal build

2
cabal-ghc901.project
View File

@ -37,7 +37,7 @@ package *
write-ghc-environment-files: never write-ghc-environment-files: never
index-state: 2021-11-29T12:30:10Z index-state: 2021-12-29T12:30:08Z
constraints: constraints:
-- These plugins don't work on GHC9 yet -- These plugins don't work on GHC9 yet

2
cabal-ghc921.project
View File

@ -36,7 +36,7 @@ package *
write-ghc-environment-files: never write-ghc-environment-files: never
index-state: 2021-11-29T12:30:10Z index-state: 2021-12-29T12:30:08Z
constraints: constraints:
-- These plugins doesn't work on GHC92 yet -- These plugins doesn't work on GHC92 yet

2
cabal.project
View File

@ -40,7 +40,7 @@ package *
write-ghc-environment-files: never write-ghc-environment-files: never
index-state: 2021-11-29T12:30:10Z index-state: 2021-12-29T12:30:08Z
constraints: constraints:
hyphenation +embed hyphenation +embed

1
ghcide/bench/example/HLS
View File

@ -1 +0,0 @@
../../..

16
ghcide/bench/lib/Experiments.hs
View File

@ -194,7 +194,7 @@ experiments =
let edit :: TextDocumentContentChangeEvent =TextDocumentContentChangeEvent let edit :: TextDocumentContentChangeEvent =TextDocumentContentChangeEvent
{ _range = Just Range {_start = bottom, _end = bottom} { _range = Just Range {_start = bottom, _end = bottom}
, _rangeLength = Nothing, _text = t} , _rangeLength = Nothing, _text = t}
bottom = Position maxBoundUinteger 0 bottom = Position maxBound 0
t = T.unlines t = T.unlines
["" [""
,"holef :: [Int] -> [Int]" ,"holef :: [Int] -> [Int]"
@ -213,7 +213,7 @@ experiments =
flip allM docs $ \DocumentPositions{..} -> do flip allM docs $ \DocumentPositions{..} -> do
bottom <- pred . length . T.lines <$> documentContents doc bottom <- pred . length . T.lines <$> documentContents doc
diags <- getCurrentDiagnostics doc diags <- getCurrentDiagnostics doc
case requireDiagnostic diags (DsError, (bottom, 8), "Found hole", Nothing) of case requireDiagnostic diags (DsError, (fromIntegral bottom, 8), "Found hole", Nothing) of
Nothing -> pure True Nothing -> pure True
Just _err -> pure False Just _err -> pure False
) )
@ -404,7 +404,7 @@ runBenchmarksFun dir allBenchmarks = do
++ ["--verbose" | verbose ?config] ++ ["--verbose" | verbose ?config]
++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]] ++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]]
lspTestCaps = lspTestCaps =
fullCaps {_window = Just $ WindowClientCapabilities $ Just True} fullCaps {_window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }
conf = conf =
defaultConfig defaultConfig
{ logStdErr = verbose ?config, { logStdErr = verbose ?config,
@ -585,7 +585,7 @@ setupDocumentContents config =
doc <- openDoc m "haskell" doc <- openDoc m "haskell"
-- Setup the special positions used by the experiments -- Setup the special positions used by the experiments
lastLine <- length . T.lines <$> documentContents doc lastLine <- fromIntegral . length . T.lines <$> documentContents doc
changeDoc doc [TextDocumentContentChangeEvent changeDoc doc [TextDocumentContentChangeEvent
{ _range = Just (Range (Position lastLine 0) (Position lastLine 0)) { _range = Just (Range (Position lastLine 0) (Position lastLine 0))
, _rangeLength = Nothing , _rangeLength = Nothing
@ -638,9 +638,9 @@ searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do
return res return res
where where
loop pos loop pos
| _line pos >= lll = | (fromIntegral $ _line pos) >= lll =
return Nothing return Nothing
| _character pos >= lengthOfLine (_line pos) = | (fromIntegral $ _character pos) >= lengthOfLine (fromIntegral $ _line pos) =
loop (nextLine pos) loop (nextLine pos)
| otherwise = do | otherwise = do
checks <- checkDefinitions pos &&^ checkCompletions pos checks <- checkDefinitions pos &&^ checkCompletions pos
@ -663,7 +663,3 @@ searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do
checkCompletions pos = checkCompletions pos =
not . null <$> getCompletions doc pos not . null <$> getCompletions doc pos
-- | We don't have a uinteger type yet. So hardcode the maxBound of uinteger, 2 ^ 31 - 1
-- as a constant.
maxBoundUinteger :: Int
maxBoundUinteger = 2147483647

4
ghcide/ghcide.cabal
View File

@ -65,8 +65,8 @@ library
lens, lens,
list-t, list-t,
hiedb == 0.4.1.*, hiedb == 0.4.1.*,
lsp-types >= 1.3.0.1 && < 1.4, lsp-types ^>= 1.4.0.0,
lsp == 1.2.*, lsp ^>= 1.4.0.0 ,
monoid-subclasses, monoid-subclasses,
mtl, mtl,
network-uri, network-uri,

7
ghcide/src/Development/IDE/Core/Compile.hs
View File

@ -564,6 +564,11 @@ indexHieFile se mod_summary srcPath !hash hf = do
done <- readTVar indexCompleted done <- readTVar indexCompleted
remaining <- HashMap.size <$> readTVar indexPending remaining <- HashMap.size <$> readTVar indexPending
pure (done, remaining) pure (done, remaining)
let
progressFrac :: Double
progressFrac = fromIntegral done / fromIntegral (done + remaining)
progressPct :: LSP.UInt
progressPct = floor $ 100 * progressFrac
whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $ whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $
LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $
@ -572,7 +577,7 @@ indexHieFile se mod_summary srcPath !hash hf = do
Percentage -> LSP.WorkDoneProgressReportParams Percentage -> LSP.WorkDoneProgressReportParams
{ _cancellable = Nothing { _cancellable = Nothing
, _message = Nothing , _message = Nothing
, _percentage = Just (100 * fromIntegral done / fromIntegral (done + remaining) ) , _percentage = Just progressPct
} }
Explicit -> LSP.WorkDoneProgressReportParams Explicit -> LSP.WorkDoneProgressReportParams
{ _cancellable = Nothing { _cancellable = Nothing

35
ghcide/src/Development/IDE/Core/OfInterest.hs
View File

@ -20,21 +20,26 @@ module Development.IDE.Core.OfInterest(
import Control.Concurrent.Strict import Control.Concurrent.Strict
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as T import qualified Data.Text as T
import Development.IDE.Graph import Development.IDE.Graph
import Control.Concurrent.STM.Stats (atomically, import Control.Concurrent.STM.Stats (atomically,
modifyTVar') modifyTVar')
import qualified Data.ByteString as BS import Data.Aeson (toJSON)
import Data.Maybe (catMaybes) import qualified Data.ByteString as BS
import Data.Maybe (catMaybes)
import Development.IDE.Core.ProgressReporting import Development.IDE.Core.ProgressReporting
import Development.IDE.Core.RuleTypes import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Shake import Development.IDE.Core.Shake
import Development.IDE.Plugin.Completions.Types
import Development.IDE.Types.Exports import Development.IDE.Types.Exports
import Development.IDE.Types.Location import Development.IDE.Types.Location
import Development.IDE.Types.Logger import Development.IDE.Types.Logger
import Development.IDE.Types.Options (IdeTesting (..))
import qualified Language.LSP.Server as LSP
import qualified Language.LSP.Types as LSP
newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))
instance IsIdeGlobal OfInterestVar instance IsIdeGlobal OfInterestVar
@ -109,11 +114,21 @@ scheduleGarbageCollection state = do
kick :: Action () kick :: Action ()
kick = do kick = do
files <- HashMap.keys <$> getFilesOfInterestUntracked files <- HashMap.keys <$> getFilesOfInterestUntracked
ShakeExtras{exportsMap, progress} <- getShakeExtras ShakeExtras{exportsMap, ideTesting = IdeTesting testing, lspEnv, progress} <- getShakeExtras
let signal msg = when testing $ liftIO $
mRunLspT lspEnv $
LSP.sendNotification (LSP.SCustomMethod msg) $
toJSON $ map fromNormalizedFilePath files
signal "kick/start"
liftIO $ progressUpdate progress KickStarted liftIO $ progressUpdate progress KickStarted
-- Update the exports map -- Update the exports map
results <- uses GenerateCore files <* uses GetHieAst files results <- uses GenerateCore files
<* uses GetHieAst files
-- needed to have non local completions on the first edit
-- when the first edit breaks the module header
<* uses NonLocalCompletions files
let mguts = catMaybes results let mguts = catMaybes results
void $ liftIO $ atomically $ modifyTVar' exportsMap (updateExportsMapMg mguts) void $ liftIO $ atomically $ modifyTVar' exportsMap (updateExportsMapMg mguts)
@ -124,3 +139,5 @@ kick = do
when garbageCollectionScheduled $ do when garbageCollectionScheduled $ do
void garbageCollectDirtyKeys void garbageCollectDirtyKeys
liftIO $ writeVar var False liftIO $ writeVar var False
signal "kick/done"

49
ghcide/src/Development/IDE/Core/PositionMapping.hs
View File

@ -31,7 +31,8 @@ import Data.List
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Vector.Unboxed as V import qualified Data.Vector.Unboxed as V
import Language.LSP.Types (Position (Position), Range (Range), import Language.LSP.Types (Position (Position), Range (Range),
TextDocumentContentChangeEvent (TextDocumentContentChangeEvent)) TextDocumentContentChangeEvent (TextDocumentContentChangeEvent),
UInt)
-- | Either an exact position, or the range of text that was substituted -- | Either an exact position, or the range of text that was substituted
data PositionResult a data PositionResult a
@ -140,14 +141,17 @@ toCurrent (Range start@(Position startLine startColumn) end@(Position endLine en
where where
lineDiff = linesNew - linesOld lineDiff = linesNew - linesOld
linesNew = T.count "\n" t linesNew = T.count "\n" t
linesOld = endLine - startLine linesOld = fromIntegral endLine - fromIntegral startLine
newEndColumn :: UInt
newEndColumn newEndColumn
| linesNew == 0 = startColumn + T.length t | linesNew == 0 = fromIntegral $ fromIntegral startColumn + T.length t
| otherwise = T.length $ T.takeWhileEnd (/= '\n') t | otherwise = fromIntegral $ T.length $ T.takeWhileEnd (/= '\n') t
newColumn :: UInt
newColumn newColumn
| line == endLine = column + newEndColumn - endColumn | line == endLine = fromIntegral $ (fromIntegral column + newEndColumn) - fromIntegral endColumn
| otherwise = column | otherwise = column
newLine = line + lineDiff newLine :: UInt
newLine = fromIntegral $ fromIntegral line + lineDiff
fromCurrent :: Range -> T.Text -> Position -> PositionResult Position fromCurrent :: Range -> T.Text -> Position -> PositionResult Position
fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column) fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column)
@ -163,19 +167,23 @@ fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine
where where
lineDiff = linesNew - linesOld lineDiff = linesNew - linesOld
linesNew = T.count "\n" t linesNew = T.count "\n" t
linesOld = endLine - startLine linesOld = fromIntegral endLine - fromIntegral startLine
newEndLine = endLine + lineDiff newEndLine :: UInt
newEndLine = fromIntegral $ fromIntegral endLine + lineDiff
newEndColumn :: UInt
newEndColumn newEndColumn
| linesNew == 0 = startColumn + T.length t | linesNew == 0 = fromIntegral $ fromIntegral startColumn + T.length t
| otherwise = T.length $ T.takeWhileEnd (/= '\n') t | otherwise = fromIntegral $ T.length $ T.takeWhileEnd (/= '\n') t
newColumn :: UInt
newColumn newColumn
| line == newEndLine = column - (newEndColumn - endColumn) | line == newEndLine = fromIntegral $ (fromIntegral column + fromIntegral endColumn) - newEndColumn
| otherwise = column | otherwise = column
newLine = line - lineDiff newLine :: UInt
newLine = fromIntegral $ fromIntegral line - lineDiff
deltaFromDiff :: T.Text -> T.Text -> PositionDelta deltaFromDiff :: T.Text -> T.Text -> PositionDelta
deltaFromDiff (T.lines -> old) (T.lines -> new) = deltaFromDiff (T.lines -> old) (T.lines -> new) =
PositionDelta (lookupPos lnew o2nPrevs o2nNexts old2new) (lookupPos lold n2oPrevs n2oNexts new2old) PositionDelta (lookupPos (fromIntegral lnew) o2nPrevs o2nNexts old2new) (lookupPos (fromIntegral lold) n2oPrevs n2oNexts new2old)
where where
!lnew = length new !lnew = length new
!lold = length old !lold = length old
@ -194,17 +202,16 @@ deltaFromDiff (T.lines -> old) (T.lines -> new) =
f :: Int -> Int -> Int f :: Int -> Int -> Int
f !a !b = if b == -1 then a else b f !a !b = if b == -1 then a else b
lookupPos :: Int -> V.Vector Int -> V.Vector Int -> V.Vector Int -> Position -> PositionResult Position lookupPos :: UInt -> V.Vector Int -> V.Vector Int -> V.Vector Int -> Position -> PositionResult Position
lookupPos end prevs nexts xs (Position line col) lookupPos end prevs nexts xs (Position line col)
| line < 0 = PositionRange (Position 0 0) (Position 0 0) | line >= fromIntegral (V.length xs) = PositionRange (Position end 0) (Position end 0)
| line >= V.length xs = PositionRange (Position end 0) (Position end 0) | otherwise = case V.unsafeIndex xs (fromIntegral line) of
| otherwise = case V.unsafeIndex xs line of
-1 -> -1 ->
-- look for the previous and next lines that mapped successfully -- look for the previous and next lines that mapped successfully
let !prev = 1 + V.unsafeIndex prevs line let !prev = 1 + V.unsafeIndex prevs (fromIntegral line)
!next = V.unsafeIndex nexts line !next = V.unsafeIndex nexts (fromIntegral line)
in PositionRange (Position prev 0) (Position next 0) in PositionRange (Position (fromIntegral prev) 0) (Position (fromIntegral next) 0)
line' -> PositionExact (Position line' col) line' -> PositionExact (Position (fromIntegral line') col)
-- Construct a mapping between lines in the diff -- Construct a mapping between lines in the diff
-- -1 for unsucessful mapping -- -1 for unsucessful mapping

14
ghcide/src/Development/IDE/Core/ProgressReporting.hs
View File

@ -152,13 +152,17 @@ delayedProgressReporting before after lspEnv optProgressStyle = do
} }
loop _ _ | optProgressStyle == NoProgress = loop _ _ | optProgressStyle == NoProgress =
forever $ liftIO $ threadDelay maxBound forever $ liftIO $ threadDelay maxBound
loop id prev = do loop id prevPct = do
done <- liftIO $ readTVarIO doneVar done <- liftIO $ readTVarIO doneVar
todo <- liftIO $ readTVarIO todoVar todo <- liftIO $ readTVarIO todoVar
liftIO $ sleep after liftIO $ sleep after
if todo == 0 then loop id 0 else do if todo == 0 then loop id 0 else do
let next = 100 * fromIntegral done / fromIntegral todo let
when (next /= prev) $ nextFrac :: Double
nextFrac = fromIntegral done / fromIntegral todo
nextPct :: UInt
nextPct = floor $ 100 * nextFrac
when (nextPct /= prevPct) $
LSP.sendNotification LSP.SProgress $ LSP.sendNotification LSP.SProgress $
LSP.ProgressParams LSP.ProgressParams
{ _token = id { _token = id
@ -171,11 +175,11 @@ delayedProgressReporting before after lspEnv optProgressStyle = do
Percentage -> LSP.WorkDoneProgressReportParams Percentage -> LSP.WorkDoneProgressReportParams
{ _cancellable = Nothing { _cancellable = Nothing
, _message = Nothing , _message = Nothing
, _percentage = Just next , _percentage = Just nextPct
} }
NoProgress -> error "unreachable" NoProgress -> error "unreachable"
} }
loop id next loop id nextPct
updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const
-- This functions are deliberately eta-expanded to avoid space leaks. -- This functions are deliberately eta-expanded to avoid space leaks.

7
ghcide/src/Development/IDE/Core/RuleTypes.hs
View File

@ -43,7 +43,8 @@ import Development.IDE.Spans.Common
import Development.IDE.Spans.LocalBindings import Development.IDE.Spans.LocalBindings
import Development.IDE.Types.Diagnostics import Development.IDE.Types.Diagnostics
import GHC.Serialized (Serialized) import GHC.Serialized (Serialized)
import Language.LSP.Types (NormalizedFilePath) import Language.LSP.Types (Int32,
NormalizedFilePath)
data LinkableType = ObjectLinkable | BCOLinkable data LinkableType = ObjectLinkable | BCOLinkable
deriving (Eq,Ord,Show, Generic) deriving (Eq,Ord,Show, Generic)
@ -290,13 +291,13 @@ pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True}
type instance RuleResult GetModificationTime = FileVersion type instance RuleResult GetModificationTime = FileVersion
data FileVersion data FileVersion
= VFSVersion !Int = VFSVersion !Int32
| ModificationTime !POSIXTime | ModificationTime !POSIXTime
deriving (Show, Generic) deriving (Show, Generic)
instance NFData FileVersion instance NFData FileVersion
vfsVersion :: FileVersion -> Maybe Int vfsVersion :: FileVersion -> Maybe Int32
vfsVersion (VFSVersion i) = Just i vfsVersion (VFSVersion i) = Just i
vfsVersion ModificationTime{} = Nothing vfsVersion ModificationTime{} = Nothing

2
ghcide/src/Development/IDE/Core/Shake.hs
View File

@ -1178,7 +1178,7 @@ updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, p
logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags
Just env -> LSP.runLspT env $ Just env -> LSP.runLspT env $
LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ LSP.sendNotification LSP.STextDocumentPublishDiagnostics $
LSP.PublishDiagnosticsParams (fromNormalizedUri uri) ver (List newDiags) LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (List newDiags)
return action return action
newtype Priority = Priority Double newtype Priority = Priority Double

4
ghcide/src/Development/IDE/GHC/Error.hs
View File

@ -79,7 +79,7 @@ realSrcSpanToRange real =
realSrcLocToPosition :: RealSrcLoc -> Position realSrcLocToPosition :: RealSrcLoc -> Position
realSrcLocToPosition real = realSrcLocToPosition real =
Position (srcLocLine real - 1) (srcLocCol real - 1) Position (fromIntegral $ srcLocLine real - 1) (fromIntegral $ srcLocCol real - 1)
-- | Extract a file name from a GHC SrcSpan (use message for unhelpful ones) -- | Extract a file name from a GHC SrcSpan (use message for unhelpful ones)
-- FIXME This may not be an _absolute_ file name, needs fixing. -- FIXME This may not be an _absolute_ file name, needs fixing.
@ -111,7 +111,7 @@ rangeToRealSrcSpan nfp =
positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc
positionToRealSrcLoc nfp (Position l c)= positionToRealSrcLoc nfp (Position l c)=
Compat.mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (l + 1) (c + 1) Compat.mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (fromIntegral $ l + 1) (fromIntegral $ c + 1)
isInsideSrcSpan :: Position -> SrcSpan -> Bool isInsideSrcSpan :: Position -> SrcSpan -> Bool
p `isInsideSrcSpan` r = case srcSpanToRange r of p `isInsideSrcSpan` r = case srcSpanToRange r of

8
ghcide/src/Development/IDE/LSP/Outline.hs
View File

@ -46,13 +46,7 @@ moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentif
(defDocumentSymbol l :: DocumentSymbol) (defDocumentSymbol l :: DocumentSymbol)
{ _name = pprText m { _name = pprText m
, _kind = SkFile , _kind = SkFile
, _range = Range (Position 0 0) (Position 2147483647 0) -- _ltop is 0 0 0 0 , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0
-- In the lsp spec from 3.16 Position takes a uinteger,
-- where uinteger is 0 - 2^31 - 1. lsp-types currently has the type of line
-- as Int. So instead of using `maxBound :: Int` we hardcode the maxBound of
-- uinteger. 2 ^ 31 - 1 == 2147483647
-- Check this issue for tracking https://github.com/haskell/lsp/issues/354
-- the change in lsp-types.
} }
_ -> Nothing _ -> Nothing
importSymbols = maybe [] pure $ importSymbols = maybe [] pure $

12
ghcide/src/Development/IDE/Plugin/CodeAction.hs
View File

@ -71,6 +71,7 @@ import Language.LSP.Types (CodeAction (
SMethod (STextDocumentCodeAction), SMethod (STextDocumentCodeAction),
TextDocumentIdentifier (TextDocumentIdentifier), TextDocumentIdentifier (TextDocumentIdentifier),
TextEdit (TextEdit), TextEdit (TextEdit),
UInt,
WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),
type (|?) (InR), type (|?) (InR),
uriToFilePath) uriToFilePath)
@ -1095,8 +1096,8 @@ suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missing
| otherwise | otherwise
= Nothing = Nothing
readPositionNumber :: T.Text -> Int readPositionNumber :: T.Text -> UInt
readPositionNumber = T.unpack >>> read readPositionNumber = T.unpack >>> read @Integer >>> fromIntegral
actionTitle :: T.Text -> T.Text actionTitle :: T.Text -> T.Text
actionTitle constraint = "Add `" <> constraint actionTitle constraint = "Add `" <> constraint
@ -1305,9 +1306,10 @@ newImportToEdit (unNewImport -> imp) ps fileContents
-- * otherwise inserted one line after the last file-header pragma -- * otherwise inserted one line after the last file-header pragma
newImportInsertRange :: ParsedSource -> T.Text -> Maybe (Range, Int) newImportInsertRange :: ParsedSource -> T.Text -> Maybe (Range, Int)
newImportInsertRange (L _ HsModule {..}) fileContents newImportInsertRange (L _ HsModule {..}) fileContents
| Just (uncurry Position -> insertPos, col) <- case hsmodImports of | Just ((l, c), col) <- case hsmodImports of
[] -> findPositionNoImports hsmodName hsmodExports fileContents [] -> findPositionNoImports hsmodName hsmodExports fileContents
_ -> findPositionFromImportsOrModuleDecl hsmodImports last True _ -> findPositionFromImportsOrModuleDecl hsmodImports last True
, let insertPos = Position (fromIntegral l) (fromIntegral c)
= Just (Range insertPos insertPos, col) = Just (Range insertPos insertPos, col)
| otherwise = Nothing | otherwise = Nothing
@ -1505,7 +1507,7 @@ extendToWholeLineIfPossible contents range@Range{..} =
in if extend then Range _start (Position (_line _end + 1) 0) else range in if extend then Range _start (Position (_line _end + 1) 0) else range
splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text) splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)
splitTextAtPosition (Position row col) x splitTextAtPosition (Position (fromIntegral -> row) (fromIntegral -> col)) x
| (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x
, (preCol, postCol) <- T.splitAt col mid , (preCol, postCol) <- T.splitAt col mid
= (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow) = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)
@ -1513,7 +1515,7 @@ splitTextAtPosition (Position row col) x
-- | Returns [start .. end[ -- | Returns [start .. end[
textInRange :: Range -> T.Text -> T.Text textInRange :: Range -> T.Text -> T.Text
textInRange (Range (Position startRow startCol) (Position endRow endCol)) text = textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCol)) (Position (fromIntegral -> endRow) (fromIntegral -> endCol))) text =
case compare startRow endRow of case compare startRow endRow of
LT -> LT ->
let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine

18
ghcide/src/Development/IDE/Plugin/Completions.hs
View File

@ -3,8 +3,6 @@
module Development.IDE.Plugin.Completions module Development.IDE.Plugin.Completions
( descriptor ( descriptor
, LocalCompletions(..)
, NonLocalCompletions(..)
) where ) where
import Control.Concurrent.Async (concurrently) import Control.Concurrent.Async (concurrently)
@ -29,7 +27,6 @@ import Development.IDE.GHC.ExactPrint (Annotated (annsA)
astA) astA)
import Development.IDE.GHC.Util (prettyPrint) import Development.IDE.GHC.Util (prettyPrint)
import Development.IDE.Graph import Development.IDE.Graph
import Development.IDE.Graph.Classes
import Development.IDE.Plugin.CodeAction (newImport, import Development.IDE.Plugin.CodeAction (newImport,
newImportToEdit) newImportToEdit)
import Development.IDE.Plugin.CodeAction.ExactPrint import Development.IDE.Plugin.CodeAction.ExactPrint
@ -41,7 +38,6 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq (envPack
import qualified Development.IDE.Types.KnownTargets as KT import qualified Development.IDE.Types.KnownTargets as KT
import Development.IDE.Types.Location import Development.IDE.Types.Location
import GHC.Exts (fromList, toList) import GHC.Exts (fromList, toList)
import GHC.Generics
import Ide.Plugin.Config (Config) import Ide.Plugin.Config (Config)
import Ide.Types import Ide.Types
import qualified Language.LSP.Server as LSP import qualified Language.LSP.Server as LSP
@ -98,20 +94,6 @@ dropListFromImportDecl iDecl = let
f x = x f x = x
in f <$> iDecl in f <$> iDecl
-- | Produce completions info for a file
type instance RuleResult LocalCompletions = CachedCompletions
type instance RuleResult NonLocalCompletions = CachedCompletions
data LocalCompletions = LocalCompletions
deriving (Eq, Show, Typeable, Generic)
instance Hashable LocalCompletions
instance NFData LocalCompletions
data NonLocalCompletions = NonLocalCompletions
deriving (Eq, Show, Typeable, Generic)
instance Hashable NonLocalCompletions
instance NFData NonLocalCompletions
-- | Generate code actions. -- | Generate code actions.
getCompletionsLSP getCompletionsLSP
:: IdeState :: IdeState

8
ghcide/src/Development/IDE/Plugin/Completions/Logic.hs
View File

@ -696,8 +696,8 @@ uniqueCompl candidate unique =
-- --------------------------------------------------------------------- -- ---------------------------------------------------------------------
hasTrailingBacktick :: T.Text -> Position -> Bool hasTrailingBacktick :: T.Text -> Position -> Bool
hasTrailingBacktick line Position { _character } hasTrailingBacktick line Position { _character=(fromIntegral -> c) }
| T.length line > _character = (line `T.index` _character) == '`' | T.length line > c = (line `T.index` c) == '`'
| otherwise = False | otherwise = False
isUsedAsInfix :: T.Text -> T.Text -> T.Text -> Position -> Maybe Backtick isUsedAsInfix :: T.Text -> T.Text -> T.Text -> Position -> Maybe Backtick
@ -710,7 +710,7 @@ isUsedAsInfix line prefixMod prefixText pos
hasClosingBacktick = hasTrailingBacktick line pos hasClosingBacktick = hasTrailingBacktick line pos
openingBacktick :: T.Text -> T.Text -> T.Text -> Position -> Bool openingBacktick :: T.Text -> T.Text -> T.Text -> Position -> Bool
openingBacktick line prefixModule prefixText Position { _character } openingBacktick line prefixModule prefixText Position { _character=(fromIntegral -> c) }
| backtickIndex < 0 || backtickIndex > T.length line = False | backtickIndex < 0 || backtickIndex > T.length line = False
| otherwise = (line `T.index` backtickIndex) == '`' | otherwise = (line `T.index` backtickIndex) == '`'
where where
@ -723,7 +723,7 @@ openingBacktick line prefixModule prefixText Position { _character }
else T.length prefixModule + 1 {- Because of "." -} else T.length prefixModule + 1 {- Because of "." -}
in in
-- Points to the first letter of either the module or prefix text -- Points to the first letter of either the module or prefix text
_character - (prefixLength + moduleLength) - 1 c - (prefixLength + moduleLength) - 1
-- --------------------------------------------------------------------- -- ---------------------------------------------------------------------

18
ghcide/src/Development/IDE/Plugin/Completions/Types.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeFamilies #-}
module Development.IDE.Plugin.Completions.Types ( module Development.IDE.Plugin.Completions.Types (
module Development.IDE.Plugin.Completions.Types module Development.IDE.Plugin.Completions.Types
) where ) where
@ -11,8 +12,11 @@ import qualified Data.Map as Map
import qualified Data.Text as T import qualified Data.Text as T
import Data.Aeson (FromJSON, ToJSON) import Data.Aeson (FromJSON, ToJSON)
import Data.Hashable (Hashable)
import Data.Text (Text) import Data.Text (Text)
import Data.Typeable (Typeable)
import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat
import Development.IDE.Graph (RuleResult)
import Development.IDE.Spans.Common import Development.IDE.Spans.Common
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Ide.Plugin.Config (Config) import Ide.Plugin.Config (Config)
@ -23,6 +27,20 @@ import Ide.Types (PluginId)
import Language.LSP.Server (MonadLsp) import Language.LSP.Server (MonadLsp)
import Language.LSP.Types (CompletionItemKind (..), Uri) import Language.LSP.Types (CompletionItemKind (..), Uri)
-- | Produce completions info for a file
type instance RuleResult LocalCompletions = CachedCompletions
type instance RuleResult NonLocalCompletions = CachedCompletions
data LocalCompletions = LocalCompletions
deriving (Eq, Show, Typeable, Generic)
instance Hashable LocalCompletions
instance NFData LocalCompletions
data NonLocalCompletions = NonLocalCompletions
deriving (Eq, Show, Typeable, Generic)
instance Hashable NonLocalCompletions
instance NFData NonLocalCompletions
-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs -- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs
data Backtick = Surrounded | LeftSide data Backtick = Surrounded | LeftSide

2
ghcide/src/Development/IDE/Plugin/TypeLenses.hs
View File

@ -174,7 +174,7 @@ suggestLocalSignature isQuickFix mTmr mBindings Diagnostic{_message, _range = _r
, startOfLine <- Position (_line _start) startCharacter , startOfLine <- Position (_line _start) startCharacter
, beforeLine <- Range startOfLine startOfLine , beforeLine <- Range startOfLine startOfLine
, title <- if isQuickFix then "add signature: " <> signature else signature , title <- if isQuickFix then "add signature: " <> signature else signature
, action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " " = , action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate (fromIntegral startCharacter) " " =
[(title, [action])] [(title, [action])]
| otherwise = [] | otherwise = []

18
ghcide/src/Development/IDE/Spans/AtPoint.hs
View File

@ -137,8 +137,8 @@ rowToLoc :: Res RefRow -> Maybe Location
rowToLoc (row:.info) = flip Location range <$> mfile rowToLoc (row:.info) = flip Location range <$> mfile
where where
range = Range start end range = Range start end
start = Position (refSLine row - 1) (refSCol row -1) start = Position (fromIntegral $ refSLine row - 1) (fromIntegral $ refSCol row -1)
end = Position (refELine row - 1) (refECol row -1) end = Position (fromIntegral $ refELine row - 1) (fromIntegral $ refECol row -1)
mfile = case modInfoSrcFile info of mfile = case modInfoSrcFile info of
Just f -> Just $ toUri f Just f -> Just $ toUri f
Nothing -> Nothing Nothing -> Nothing
@ -149,8 +149,8 @@ typeRowToLoc (row:.info) = do
pure $ Location (toUri file) range pure $ Location (toUri file) range
where where
range = Range start end range = Range start end
start = Position (typeRefSLine row - 1) (typeRefSCol row -1) start = Position (fromIntegral $ typeRefSLine row - 1) (fromIntegral $ typeRefSCol row -1)
end = Position (typeRefELine row - 1) (typeRefECol row -1) end = Position (fromIntegral $ typeRefELine row - 1) (fromIntegral $ typeRefECol row -1)
documentHighlight documentHighlight
:: Monad m :: Monad m
@ -361,8 +361,8 @@ nameToLocation withHieDb lookupModule name = runMaybeT $
defRowToLocation :: Monad m => LookupModule m -> Res DefRow -> MaybeT m Location defRowToLocation :: Monad m => LookupModule m -> Res DefRow -> MaybeT m Location
defRowToLocation lookupModule (row:.info) = do defRowToLocation lookupModule (row:.info) = do
let start = Position (defSLine row - 1) (defSCol row - 1) let start = Position (fromIntegral $ defSLine row - 1) (fromIntegral $ defSCol row - 1)
end = Position (defELine row - 1) (defECol row - 1) end = Position (fromIntegral $ defELine row - 1) (fromIntegral $ defECol row - 1)
range = Range start end range = Range start end
file <- case modInfoSrcFile info of file <- case modInfoSrcFile info of
Just src -> pure $ toUri src Just src -> pure $ toUri src
@ -384,8 +384,8 @@ defRowToSymbolInfo (DefRow{..}:.(modInfoSrcFile -> Just srcFile))
loc = Location file range loc = Location file range
file = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' $ srcFile file = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' $ srcFile
range = Range start end range = Range start end
start = Position (defSLine - 1) (defSCol - 1) start = Position (fromIntegral $ defSLine - 1) (fromIntegral $ defSCol - 1)
end = Position (defELine - 1) (defECol - 1) end = Position (fromIntegral $ defELine - 1) (fromIntegral $ defECol - 1)
defRowToSymbolInfo _ = Nothing defRowToSymbolInfo _ = Nothing
pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a] pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a]
@ -405,7 +405,7 @@ pointCommand hf pos k =
Nothing -> Nothing Nothing -> Nothing
Just ast' -> Just $ k ast' Just ast' -> Just $ k ast'
where where
sloc fs = mkRealSrcLoc fs (line+1) (cha+1) sloc fs = mkRealSrcLoc fs (fromIntegral $ line+1) (fromIntegral $ cha+1)
sp fs = mkRealSrcSpan (sloc fs) (sloc fs) sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
line = _line pos line = _line pos
cha = _character pos cha = _character pos

8
ghcide/src/Development/IDE/Spans/Pragmas.hs
View File

@ -85,7 +85,7 @@ updateLineSplitTextEdits tokenRange tokenString prevLineSplitTextEdits
, let currInsertRange = prevInsertRange , let currInsertRange = prevInsertRange
, let currInsertText = , let currInsertText =
Text.init prevInsertText Text.init prevInsertText
<> Text.replicate (startCol - prevDeleteEndCol) " " <> Text.replicate (fromIntegral $ startCol - prevDeleteEndCol) " "
<> Text.pack (List.take newLineCol tokenString) <> Text.pack (List.take newLineCol tokenString)
<> "\n" <> "\n"
, let currInsertTextEdit = LSP.TextEdit currInsertRange currInsertText , let currInsertTextEdit = LSP.TextEdit currInsertRange currInsertText
@ -96,7 +96,7 @@ updateLineSplitTextEdits tokenRange tokenString prevLineSplitTextEdits
= LineSplitTextEdits currInsertTextEdit currDeleteTextEdit = LineSplitTextEdits currInsertTextEdit currDeleteTextEdit
| otherwise | otherwise
, let LSP.Range startPos _ = tokenRange , let LSP.Range startPos _ = tokenRange
, let deleteTextEdit = LSP.TextEdit (LSP.Range startPos startPos{ LSP._character = startCol + newLineCol }) "" , let deleteTextEdit = LSP.TextEdit (LSP.Range startPos startPos{ LSP._character = startCol + fromIntegral newLineCol }) ""
, let insertPosition = LSP.Position (startLine + 1) 0 , let insertPosition = LSP.Position (startLine + 1) 0
, let insertRange = LSP.Range insertPosition insertPosition , let insertRange = LSP.Range insertPosition insertPosition
, let insertText = Text.pack (List.take newLineCol tokenString) <> "\n" , let insertText = Text.pack (List.take newLineCol tokenString) <> "\n"
@ -117,7 +117,7 @@ updateParserState token range prevParserState
, lastPragmaLine , lastPragmaLine
} <- prevParserState } <- prevParserState
, let defaultParserState = prevParserState { isLastTokenHash = False } , let defaultParserState = prevParserState { isLastTokenHash = False }
, let LSP.Range (LSP.Position startLine _) (LSP.Position endLine _) = range , let LSP.Range (LSP.Position (fromIntegral -> startLine) _) (LSP.Position (fromIntegral -> endLine) _) = range
= case prevMode of = case prevMode of
ModeInitial -> ModeInitial ->
case token of case token of
@ -235,7 +235,7 @@ updateParserState token range prevParserState
, let LSP.TextEdit deleteRange _ = lineSplitDeleteTextEdit , let LSP.TextEdit deleteRange _ = lineSplitDeleteTextEdit
, let LSP.Range _ deleteEndPosition = deleteRange , let LSP.Range _ deleteEndPosition = deleteRange
, let LSP.Position deleteEndLine _ = deleteEndPosition , let LSP.Position deleteEndLine _ = deleteEndPosition
= deleteEndLine == line = fromIntegral deleteEndLine == line
| otherwise = False | otherwise = False
lexUntilNextLineIncl :: P (Located Token) lexUntilNextLineIncl :: P (Located Token)

2
ghcide/src/Development/IDE/Types/Diagnostics.hs
View File

@ -92,7 +92,7 @@ type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic)
prettyRange :: Range -> Doc Terminal.AnsiStyle prettyRange :: Range -> Doc Terminal.AnsiStyle
prettyRange Range{..} = f _start <> "-" <> f _end prettyRange Range{..} = f _start <> "-" <> f _end
where f Position{..} = pretty (_line+1) <> colon <> pretty (_character+1) where f Position{..} = pretty (show $ _line+1) <> colon <> pretty (show $ _character+1)
stringParagraphs :: T.Text -> Doc a stringParagraphs :: T.Text -> Doc a
stringParagraphs = vcat . map (fillSep . map pretty . T.words) . T.lines stringParagraphs = vcat . map (fillSep . map pretty . T.words) . T.lines

69
ghcide/test/exe/Main.hs
View File

@ -89,7 +89,7 @@ import System.Process.Extra (CreateProcess (cwd),
import Test.QuickCheck import Test.QuickCheck
-- import Test.QuickCheck.Instances () -- import Test.QuickCheck.Instances ()
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Lens ((^.)) import Control.Lens ((^.), to)
import Control.Monad.Extra (whenJust) import Control.Monad.Extra (whenJust)
import Data.IORef import Data.IORef
import Data.IORef.Extra (atomicModifyIORef_) import Data.IORef.Extra (atomicModifyIORef_)
@ -1993,8 +1993,8 @@ suggestImportTests = testGroup "suggest import actions"
_diags <- waitForDiagnostics _diags <- waitForDiagnostics
-- there isn't a good way to wait until the whole project is checked atm -- there isn't a good way to wait until the whole project is checked atm
when waitForCheckProject $ liftIO $ sleep 0.5 when waitForCheckProject $ liftIO $ sleep 0.5
let defLine = length imps + 1 let defLine = fromIntegral $ length imps + 1
range = Range (Position defLine 0) (Position defLine maxBoundUinteger) range = Range (Position defLine 0) (Position defLine maxBound)
actions <- getCodeActions doc range actions <- getCodeActions doc range
if wanted if wanted
then do then do
@ -2307,7 +2307,7 @@ suggestHideShadowTests =
doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin) doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin)
void waitForDiagnostics void waitForDiagnostics
waitForProgressDone waitForProgressDone
cas <- getCodeActions doc (Range (Position (line1 + length header) col1) (Position (line2 + length header) col2)) cas <- getCodeActions doc (Range (Position (fromIntegral $ line1 + length header) col1) (Position (fromIntegral $ line2 + length header) col2))
void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)] void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)]
contentAfter <- documentContents doc contentAfter <- documentContents doc
liftIO $ contentAfter @?= T.unlines (header <> expected) liftIO $ contentAfter @?= T.unlines (header <> expected)
@ -2742,7 +2742,7 @@ fillTypedHoleTests = let
let expectedCode = sourceCode newA newB newC let expectedCode = sourceCode newA newB newC
doc <- createDoc "Testing.hs" "haskell" originalCode doc <- createDoc "Testing.hs" "haskell" originalCode
_ <- waitForDiagnostics _ <- waitForDiagnostics
actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBoundUinteger)) actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
executeCodeAction chosenAction executeCodeAction chosenAction
modifiedCode <- documentContents doc modifiedCode <- documentContents doc
@ -2783,7 +2783,7 @@ fillTypedHoleTests = let
, "ioToSome = " <> x ] , "ioToSome = " <> x ]
doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException" doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException"
_ <- waitForDiagnostics _ <- waitForDiagnostics
actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBoundUinteger)) actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound))
chosen <- liftIO $ pickActionWithTitle "replace _toException with E.toException" actions chosen <- liftIO $ pickActionWithTitle "replace _toException with E.toException" actions
executeCodeAction chosen executeCodeAction chosen
modifiedCode <- documentContents doc modifiedCode <- documentContents doc
@ -3278,7 +3278,7 @@ addSigActionTests = let
let expectedCode = after' def sig let expectedCode = after' def sig
doc <- createDoc "Sigs.hs" "haskell" originalCode doc <- createDoc "Sigs.hs" "haskell" originalCode
_ <- waitForDiagnostics _ <- waitForDiagnostics
actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBoundUinteger)) actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBound))
chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
executeCodeAction chosenAction executeCodeAction chosenAction
modifiedCode <- documentContents doc modifiedCode <- documentContents doc
@ -4093,9 +4093,9 @@ cppTests =
"foo = 42" "foo = 42"
] ]
-- The error locations differ depending on which C-preprocessor is used. -- The error locations differ depending on which C-preprocessor is used.
-- Some give the column number and others don't (hence -1). Assert either -- Some give the column number and others don't (hence maxBound == -1 unsigned). Assert either
-- of them. -- of them.
(run $ expectError content (2, -1)) (run $ expectError content (2, maxBound))
`catch` ( \e -> do `catch` ( \e -> do
let _ = e :: HUnitFailure let _ = e :: HUnitFailure
run $ expectError content (2, 1) run $ expectError content (2, 1)
@ -5187,7 +5187,7 @@ outlineTests = testGroup
SkFile SkFile
Nothing Nothing
Nothing Nothing
(R 0 0 maxBoundUinteger 0) (R 0 0 maxBound 0)
loc loc
(Just $ List cc) (Just $ List cc)
classSymbol name loc cc = DocumentSymbol name classSymbol name loc cc = DocumentSymbol name
@ -5199,7 +5199,7 @@ outlineTests = testGroup
loc loc
(Just $ List cc) (Just $ List cc)
pattern R :: Int -> Int -> Int -> Int -> Range pattern R :: UInt -> UInt -> UInt -> UInt -> Range
pattern R x y x' y' = Range (Position x y) (Position x' y') pattern R x y x' y' = Range (Position x y) (Position x' y')
xfail :: TestTree -> String -> TestTree xfail :: TestTree -> String -> TestTree
@ -5240,10 +5240,10 @@ data Expect
-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples -- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
deriving Eq deriving Eq
mkR :: Int -> Int -> Int -> Int -> Expect mkR :: UInt -> UInt -> UInt -> UInt -> Expect
mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
mkL :: Uri -> Int -> Int -> Int -> Int -> Expect mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect
mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
haddockTests :: TestTree haddockTests :: TestTree
@ -5930,14 +5930,14 @@ referenceTest name loc includeDeclaration expected =
where where
docs = map fst3 expected docs = map fst3 expected
type SymbolLocation = (FilePath, Int, Int) type SymbolLocation = (FilePath, UInt, UInt)
expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion
expectSameLocations actual expected = do expectSameLocations actual expected = do
let actual' = let actual' =
Set.map (\location -> (location ^. L.uri Set.map (\location -> (location ^. L.uri
, location ^. L.range . L.start . L.line , location ^. L.range . L.start . L.line . to fromIntegral
, location ^. L.range . L.start . L.character)) , location ^. L.range . L.start . L.character . to fromIntegral))
$ Set.fromList actual $ Set.fromList actual
expected' <- Set.fromList <$> expected' <- Set.fromList <$>
(forM expected $ \(file, l, c) -> do (forM expected $ \(file, l, c) -> do
@ -5983,7 +5983,7 @@ pickActionWithTitle title actions = do
, title == actionTitle , title == actionTitle
] ]
mkRange :: Int -> Int -> Int -> Int -> Range mkRange :: UInt -> UInt -> UInt -> UInt -> Range
mkRange a b c d = Range (Position a b) (Position c d) mkRange a b c d = Range (Position a b) (Position c d)
run :: Session a -> IO a run :: Session a -> IO a
@ -6052,7 +6052,7 @@ getConfigFromEnv = do
convertVal _ = True convertVal _ = True
lspTestCaps :: ClientCapabilities lspTestCaps :: ClientCapabilities
lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }
openTestDataDoc :: FilePath -> Session TextDocumentIdentifier openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
openTestDataDoc path = do openTestDataDoc path = do
@ -6384,24 +6384,28 @@ genRope = Rope.fromText . getPrintableText <$> arbitrary
genPosition :: Rope -> Gen Position genPosition :: Rope -> Gen Position
genPosition r = do genPosition r = do
row <- choose (0, max 0 $ rows - 1) let rows = Rope.rows r
row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt
let columns = Rope.columns (nthLine row r) let columns = Rope.columns (nthLine row r)
column <- choose (0, max 0 $ columns - 1) column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt
pure $ Position row column pure $ Position (fromIntegral row) (fromIntegral column)
where rows = Rope.rows r
genRange :: Rope -> Gen Range genRange :: Rope -> Gen Range
genRange r = do genRange r = do
let rows = Rope.rows r
startPos@(Position startLine startColumn) <- genPosition r startPos@(Position startLine startColumn) <- genPosition r
let maxLineDiff = max 0 $ rows - 1 - startLine let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine
endLine <- choose (startLine, startLine + maxLineDiff) endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt
let columns = Rope.columns (nthLine endLine r) let columns = Rope.columns (nthLine (fromIntegral endLine) r)
endColumn <- endColumn <-
if startLine == endLine if fromIntegral startLine == endLine
then choose (startColumn, columns) then choose (fromIntegral startColumn, columns)
else choose (0, max 0 $ columns - 1) else choose (0, max 0 $ columns - 1)
pure $ Range startPos (Position endLine endColumn) `suchThat` inBounds @UInt
where rows = Rope.rows r pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn))
inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool
inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b)
-- | Get the ith line of a rope, starting from 0. Trailing newline not included. -- | Get the ith line of a rope, starting from 0. Trailing newline not included.
nthLine :: Int -> Rope -> Rope nthLine :: Int -> Rope -> Rope
@ -6440,11 +6444,6 @@ listOfChar | ghcVersion >= GHC90 = "String"
| otherwise = "[Char]" | otherwise = "[Char]"
-- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did -- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did
thDollarIdx :: Int thDollarIdx :: UInt
thDollarIdx | ghcVersion >= GHC90 = 1 thDollarIdx | ghcVersion >= GHC90 = 1
| otherwise = 0 | otherwise = 0
-- | We don't have a uinteger type yet. So hardcode the maxBound of uinteger, 2 ^ 31 - 1
-- as a constant.
maxBoundUinteger :: Int
maxBoundUinteger = 2147483647

2
ghcide/test/src/Development/IDE/Test/Diagnostic.hs
View File

@ -7,7 +7,7 @@ import Language.LSP.Types
import Language.LSP.Types.Lens as Lsp import Language.LSP.Types.Lens as Lsp
-- | (0-based line number, 0-based column number) -- | (0-based line number, 0-based column number)
type Cursor = (Int, Int) type Cursor = (UInt, UInt)
cursorPosition :: Cursor -> Position cursorPosition :: Cursor -> Position
cursorPosition (line, col) = Position line col cursorPosition (line, col) = Position line col

2
hls-plugin-api/hls-plugin-api.cabal
View File

@ -49,7 +49,7 @@ library
, hls-graph >=1.4 && < 1.6 , hls-graph >=1.4 && < 1.6
, hslogger , hslogger
, lens , lens
, lsp ^>=1.2.0.1 , lsp ^>=1.4.0.0
, opentelemetry , opentelemetry
, optparse-applicative , optparse-applicative
, process , process

20
hls-plugin-api/src/Ide/PluginUtils.hs
View File

@ -107,15 +107,15 @@ diffTextEdit fText f2Text withDeletions = J.List r
-} -}
diffOperationToTextEdit (Deletion (LineRange (sl, el) _) _) = J.TextEdit range "" diffOperationToTextEdit (Deletion (LineRange (sl, el) _) _) = J.TextEdit range ""
where where
range = J.Range (J.Position (sl - 1) 0) range = J.Range (J.Position (fromIntegral $ sl - 1) 0)
(J.Position el 0) (J.Position (fromIntegral el) 0)
diffOperationToTextEdit (Addition fm l) = J.TextEdit range nt diffOperationToTextEdit (Addition fm l) = J.TextEdit range nt
-- fm has a range wrt to the changed file, which starts in the current file at l + 1 -- fm has a range wrt to the changed file, which starts in the current file at l + 1
-- So the range has to be shifted to start at l + 1 -- So the range has to be shifted to start at l + 1
where where
range = J.Range (J.Position l 0) range = J.Range (J.Position (fromIntegral l) 0)
(J.Position l 0) (J.Position (fromIntegral l) 0)
nt = T.pack $ unlines $ lrContents fm nt = T.pack $ unlines $ lrContents fm
@ -123,10 +123,10 @@ diffTextEdit fText f2Text withDeletions = J.List r
where where
sl = fst $ lrNumbers fm sl = fst $ lrNumbers fm
sc = 0 sc = 0
s = J.Position (sl - 1) sc -- Note: zero-based lines s = J.Position (fromIntegral $ sl - 1) sc -- Note: zero-based lines
el = snd $ lrNumbers fm el = snd $ lrNumbers fm
ec = length $ last $ lrContents fm ec = fromIntegral $ length $ last $ lrContents fm
e = J.Position (el - 1) ec -- Note: zero-based lines e = J.Position (fromIntegral $ el - 1) ec -- Note: zero-based lines
-- | A pure version of 'diffText' for testing -- | A pure version of 'diffText' for testing
@ -145,7 +145,7 @@ diffText' supports (f,fText) f2Text withDeletions =
clientSupportsDocumentChanges :: ClientCapabilities -> Bool clientSupportsDocumentChanges :: ClientCapabilities -> Bool
clientSupportsDocumentChanges caps = clientSupportsDocumentChanges caps =
let ClientCapabilities mwCaps _ _ _ = caps let ClientCapabilities mwCaps _ _ _ _ = caps
supports = do supports = do
wCaps <- mwCaps wCaps <- mwCaps
WorkspaceEditClientCapabilities mDc _ _ _ _ <- _workspaceEdit wCaps WorkspaceEditClientCapabilities mDc _ _ _ _ <- _workspaceEdit wCaps
@ -197,7 +197,7 @@ usePropertyLsp kn pId p = do
extractRange :: Range -> T.Text -> T.Text extractRange :: Range -> T.Text -> T.Text
extractRange (Range (Position sl _) (Position el _)) s = newS extractRange (Range (Position sl _) (Position el _)) s = newS
where focusLines = take (el-sl+1) $ drop sl $ T.lines s where focusLines = take (fromIntegral $ el-sl+1) $ drop (fromIntegral sl) $ T.lines s
newS = T.unlines focusLines newS = T.unlines focusLines
-- | Gets the range that covers the entire text -- | Gets the range that covers the entire text
@ -212,7 +212,7 @@ fullRange s = Range startPos endPos
the line ending character(s) then use an end position denoting the line ending character(s) then use an end position denoting
the start of the next line" the start of the next line"
-} -}
lastLine = length $ T.lines s lastLine = fromIntegral $ length $ T.lines s
subRange :: Range -> Range -> Bool subRange :: Range -> Range -> Bool
subRange smallRange range = subRange smallRange range =

4
hls-plugin-api/src/Ide/Types.hs
View File

@ -178,7 +178,7 @@ class HasTracing (MessageParams m) => PluginMethod m where
instance PluginMethod TextDocumentCodeAction where instance PluginMethod TextDocumentCodeAction where
pluginEnabled _ = pluginEnabledConfig plcCodeActionsOn pluginEnabled _ = pluginEnabledConfig plcCodeActionsOn
combineResponses _method _config (ClientCapabilities _ textDocCaps _ _) (CodeActionParams _ _ _ _ context) resps = combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _) (CodeActionParams _ _ _ _ context) resps =
fmap compat $ List $ filter wasRequested $ (\(List x) -> x) $ sconcat resps fmap compat $ List $ filter wasRequested $ (\(List x) -> x) $ sconcat resps
where where
@ -224,7 +224,7 @@ instance PluginMethod TextDocumentHover where
instance PluginMethod TextDocumentDocumentSymbol where instance PluginMethod TextDocumentDocumentSymbol where
pluginEnabled _ = pluginEnabledConfig plcSymbolsOn pluginEnabled _ = pluginEnabledConfig plcSymbolsOn
combineResponses _ _ (ClientCapabilities _ tdc _ _) params xs = res combineResponses _ _ (ClientCapabilities _ tdc _ _ _) params xs = res
where where
uri' = params ^. textDocument . uri uri' = params ^. textDocument . uri
supportsHierarchy = Just True == (tdc >>= _documentSymbol >>= _hierarchicalDocumentSymbolSupport) supportsHierarchy = Just True == (tdc >>= _documentSymbol >>= _hierarchicalDocumentSymbolSupport)

4
hls-test-utils/hls-test-utils.cabal
View File

@ -47,9 +47,9 @@ library
, hspec <2.8 , hspec <2.8
, hspec-core , hspec-core
, lens , lens
, lsp ^>=1.2 , lsp ^>=1.4
, lsp-test ^>=0.14 , lsp-test ^>=0.14
, lsp-types >=1.2 && <1.4 , lsp-types ^>=1.4
, tasty , tasty
, tasty-expected-failure , tasty-expected-failure
, tasty-golden , tasty-golden

30
hls-test-utils/src/Test/Hls.hs
View File

@ -28,16 +28,21 @@ module Test.Hls
waitForTypecheck, waitForTypecheck,
waitForAction, waitForAction,
sendConfigurationChanged, sendConfigurationChanged,
getLastBuildKeys) getLastBuildKeys,
waitForKickDone,
waitForKickStart,
)
where where
import Control.Applicative.Combinators import Control.Applicative.Combinators
import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Async (async, cancel, wait)
import Control.Concurrent.Extra import Control.Concurrent.Extra
import Control.Exception.Base import Control.Exception.Base
import Control.Monad (unless, void) import Control.Monad (guard, unless, void)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Data.Aeson (Value (Null), toJSON) import Data.Aeson (Result (Success),
Value (Null), fromJSON,
toJSON)
import qualified Data.Aeson as A import qualified Data.Aeson as A
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
import Data.Default (def) import Data.Default (def)
@ -247,3 +252,22 @@ getLastBuildKeys = callTestPlugin GetBuildKeysBuilt
sendConfigurationChanged :: Value -> Session () sendConfigurationChanged :: Value -> Session ()
sendConfigurationChanged config = sendConfigurationChanged config =
sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams config) sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams config)
waitForKickDone :: Session ()
waitForKickDone = void $ skipManyTill anyMessage nonTrivialKickDone
waitForKickStart :: Session ()
waitForKickStart = void $ skipManyTill anyMessage nonTrivialKickStart
nonTrivialKickDone :: Session ()
nonTrivialKickDone = kick "done" >>= guard . not . null
nonTrivialKickStart :: Session ()
nonTrivialKickStart = kick "start" >>= guard . not . null
kick :: T.Text -> Session [FilePath]
kick msg = do
NotMess NotificationMessage{_params} <- customNotification $ "kick/" <> msg
case fromJSON _params of
Success x -> return x
other -> error $ "Failed to parse kick/done details: " <> show other

2
hls-test-utils/src/Test/Hls/Util.hs
View File

@ -433,7 +433,7 @@ failIfSessionTimeout action = action `catch` errorHandler
-- | To locate a symbol, we provide a path to the file from the HLS root -- | To locate a symbol, we provide a path to the file from the HLS root
-- directory, the line number, and the column number. (0 indexed.) -- directory, the line number, and the column number. (0 indexed.)
type SymbolLocation = (FilePath, Int, Int) type SymbolLocation = (FilePath, UInt, UInt)
expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion
actual `expectSameLocations` expected = do actual `expectSameLocations` expected = do

4
plugins/hls-alternate-number-format-plugin/test/Main.hs
View File

@ -133,8 +133,8 @@ codeActionTitle' CodeAction{_title} = _title
pointRange :: Int -> Int -> Range pointRange :: Int -> Int -> Range
pointRange pointRange
(subtract 1 -> line) (subtract 1 -> fromIntegral -> line)
(subtract 1 -> col) = (subtract 1 -> fromIntegral -> col) =
Range (Position line col) (Position line $ col + 1) Range (Position line col) (Position line $ col + 1)
contains :: [CodeAction] -> Text -> Bool contains :: [CodeAction] -> Text -> Bool

66
plugins/hls-brittany-plugin/src/Ide/Plugin/Brittany.hs
View File

@ -1,48 +1,54 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE LambdaCase #-}
module Ide.Plugin.Brittany where module Ide.Plugin.Brittany where
import Control.Exception (bracket_) import Control.Exception (bracket_)
import Control.Lens import Control.Lens
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) import Control.Monad.Trans.Maybe (MaybeT,
import Data.Maybe (mapMaybe, maybeToList, fromMaybe) runMaybeT)
import Data.Maybe (fromMaybe,
mapMaybe,
maybeToList)
import Data.Semigroup import Data.Semigroup
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Development.IDE hiding (pluginHandlers) import Development.IDE hiding
import qualified Development.IDE.GHC.Compat as GHC hiding (Cpp) (pluginHandlers)
import qualified DynFlags as D import qualified Development.IDE.GHC.Compat as GHC hiding
import qualified EnumSet as S (Cpp)
import qualified DynFlags as D
import qualified EnumSet as S
import GHC.LanguageExtensions.Type import GHC.LanguageExtensions.Type
import Ide.PluginUtils import Ide.PluginUtils
import Ide.Types import Ide.Types
import Language.Haskell.Brittany import Language.Haskell.Brittany
import Language.LSP.Types as J import Language.LSP.Types as J
import qualified Language.LSP.Types.Lens as J import qualified Language.LSP.Types.Lens as J
import System.Environment (setEnv, unsetEnv) import System.Environment (setEnv,
unsetEnv)
import System.FilePath import System.FilePath
-- These imports are for the temporary pPrintText & can be removed when -- These imports are for the temporary pPrintText & can be removed when
-- issue #2005 is resolved -- issue #2005 is resolved
import Language.Haskell.Brittany.Internal.Config.Types import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.Except as ExceptT
import Data.CZipWith
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TextL
import qualified GHC
import qualified GHC.LanguageExtensions.Type as GHC
import Language.Haskell.Brittany.Internal import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Obfuscation
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Obfuscation import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.Brittany.Internal.Config import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import Data.CZipWith
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.Except as ExceptT
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified Data.Text.Lazy as TextL
import qualified GHC
import qualified GHC.LanguageExtensions.Type as GHC
descriptor :: PluginId -> PluginDescriptor IdeState descriptor :: PluginId -> PluginDescriptor IdeState
@ -80,7 +86,7 @@ formatText
-> m (Either [BrittanyError] Text) -- ^ Either formatted Text or a error from Brittany. -> m (Either [BrittanyError] Text) -- ^ Either formatted Text or a error from Brittany.
formatText df confFile opts text = formatText df confFile opts text =
liftIO $ runBrittany tabSize df confFile text liftIO $ runBrittany tabSize df confFile text
where tabSize = opts ^. J.tabSize where tabSize = fromIntegral $ opts ^. J.tabSize
-- | Recursively search in every directory of the given filepath for brittany.yaml. -- | Recursively search in every directory of the given filepath for brittany.yaml.
-- If no such file has been found, return Nothing. -- If no such file has been found, return Nothing.
@ -261,6 +267,6 @@ pPrintText config text =
isError :: BrittanyError -> Bool isError :: BrittanyError -> Bool
isError = \case isError = \case
LayoutWarning{} -> False LayoutWarning{} -> False
ErrorUnknownNode{} -> False ErrorUnknownNode{} -> False
_ -> True _ -> True

6
plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs
View File

@ -234,9 +234,9 @@ outgoingCalls state pluginId param = do
mkCallHierarchyCall :: (CallHierarchyItem -> List Range -> a) -> Vertex -> Action (Maybe a) mkCallHierarchyCall :: (CallHierarchyItem -> List Range -> a) -> Vertex -> Action (Maybe a)
mkCallHierarchyCall mk v@Vertex{..} = do mkCallHierarchyCall mk v@Vertex{..} = do
let pos = Position (sl - 1) (sc - 1) let pos = Position (fromIntegral $ sl - 1) (fromIntegral $ sc - 1)
nfp = toNormalizedFilePath' hieSrc nfp = toNormalizedFilePath' hieSrc
range = mkRange (casl - 1) (casc - 1) (cael - 1) (caec - 1) range = mkRange (fromIntegral $ casl - 1) (fromIntegral $ casc - 1) (fromIntegral $ cael - 1) (fromIntegral $ caec - 1)
prepareCallHierarchyItem nfp pos >>= prepareCallHierarchyItem nfp pos >>=
\case \case
@ -246,7 +246,7 @@ mkCallHierarchyCall mk v@Vertex{..} = do
liftIO (withHieDb (`Q.getSymbolPosition` v)) >>= liftIO (withHieDb (`Q.getSymbolPosition` v)) >>=
\case \case
(x:_) -> (x:_) ->
prepareCallHierarchyItem nfp (Position (psl x - 1) (psc x - 1)) >>= prepareCallHierarchyItem nfp (Position (fromIntegral $ psl x - 1) (fromIntegral $ psc x - 1)) >>=
\case \case
Just [item] -> pure $ Just $ mk item (List [range]) Just [item] -> pure $ Just $ mk item (List [range])
_ -> pure Nothing _ -> pure Nothing

2
plugins/hls-call-hierarchy-plugin/test/Main.hs
View File

@ -528,7 +528,7 @@ testDataDir :: FilePath
testDataDir = "test" </> "testdata" testDataDir = "test" </> "testdata"
mkPrepareCallHierarchyParam :: TextDocumentIdentifier -> Int -> Int -> CallHierarchyPrepareParams mkPrepareCallHierarchyParam :: TextDocumentIdentifier -> Int -> Int -> CallHierarchyPrepareParams
mkPrepareCallHierarchyParam doc x y = CallHierarchyPrepareParams doc (Position x y) Nothing mkPrepareCallHierarchyParam doc x y = CallHierarchyPrepareParams doc (Position (fromIntegral x) (fromIntegral y)) Nothing
mkIncomingCallsParam :: CallHierarchyItem -> CallHierarchyIncomingCallsParams mkIncomingCallsParam :: CallHierarchyItem -> CallHierarchyIncomingCallsParams
mkIncomingCallsParam = CallHierarchyIncomingCallsParams Nothing Nothing mkIncomingCallsParam = CallHierarchyIncomingCallsParams Nothing Nothing

11
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-} {-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-}
@ -27,7 +28,7 @@ import System.IO.Extra (newTempFile, readFile')
testRanges :: Test -> (Range, Range) testRanges :: Test -> (Range, Range)
testRanges tst = testRanges tst =
let startLine = testRange tst ^. start.line let startLine = testRange tst ^. start.line
(exprLines, resultLines) = testLenghts tst (fromIntegral -> exprLines, fromIntegral -> resultLines) = testLengths tst
resLine = startLine + exprLines resLine = startLine + exprLines
in ( Range in ( Range
(Position startLine 0) (Position startLine 0)
@ -63,15 +64,15 @@ testCheck (section, test) out
| null (testOutput test) || sectionLanguage section == Plain = out | null (testOutput test) || sectionLanguage section == Plain = out
| otherwise = showDiffs $ getDiff (map T.pack $ testOutput test) out | otherwise = showDiffs $ getDiff (map T.pack $ testOutput test) out
testLenghts :: Test -> (Int, Int) testLengths :: Test -> (Int, Int)
testLenghts (Example e r _) = (NE.length e, length r) testLengths (Example e r _) = (NE.length e, length r)
testLenghts (Property _ r _) = (1, length r) testLengths (Property _ r _) = (1, length r)
-- |A one-line Haskell statement -- |A one-line Haskell statement
type Statement = Loc String type Statement = Loc String
asStatements :: Test -> [Statement] asStatements :: Test -> [Statement]
asStatements lt = locate $ Located (testRange lt ^. start.line) (asStmts lt) asStatements lt = locate $ Located (fromIntegral $ testRange lt ^. start.line) (asStmts lt)
asStmts :: Test -> [Txt] asStmts :: Test -> [Txt]
asStmts (Example e _ _) = NE.toList e asStmts (Example e _ _) = NE.toList e

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

@ -326,8 +326,8 @@ addFinalReturn mdlText edits
finalReturn :: Text -> TextEdit finalReturn :: Text -> TextEdit
finalReturn txt = finalReturn txt =
let ls = T.lines txt let ls = T.lines txt
l = length ls -1 l = fromIntegral $ length ls -1
c = T.length . last $ ls c = fromIntegral $ T.length . last $ ls
p = Position l c p = Position l c
in TextEdit (Range p p) "\n" in TextEdit (Range p p) "\n"

11
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs
View File

@ -36,8 +36,9 @@ import Data.Void (Void)
import Development.IDE (Position, import Development.IDE (Position,
Range (Range)) Range (Range))
import Development.IDE.Types.Location (Position (..)) import Development.IDE.Types.Location (Position (..))
import GHC.Generics import GHC.Generics hiding (to, UInt)
import Ide.Plugin.Eval.Types import Ide.Plugin.Eval.Types
import Language.LSP.Types (UInt)
import Language.LSP.Types.Lens (character, end, line, import Language.LSP.Types.Lens (character, end, line,
start) start)
import Text.Megaparsec import Text.Megaparsec
@ -329,13 +330,13 @@ positionToSourcePos :: Position -> SourcePos
positionToSourcePos pos = positionToSourcePos pos =
P.SourcePos P.SourcePos
{ sourceName = "<block comment>" { sourceName = "<block comment>"
, sourceLine = P.mkPos $ 1 + pos ^. line , sourceLine = P.mkPos $ fromIntegral $ 1 + pos ^. line
, sourceColumn = P.mkPos $ 1 + pos ^. character , sourceColumn = P.mkPos $ fromIntegral $ 1 + pos ^. character
} }
sourcePosToPosition :: SourcePos -> Position sourcePosToPosition :: SourcePos -> Position
sourcePosToPosition SourcePos {..} = sourcePosToPosition SourcePos {..} =
Position (unPos sourceLine - 1) (unPos sourceColumn - 1) Position (fromIntegral $ unPos sourceLine - 1) (fromIntegral $ unPos sourceColumn - 1)
-- * Line Group Parser -- * Line Group Parser
@ -550,7 +551,7 @@ Two adjacent tokens are considered to be contiguous if
>>> contiguousGroupOn id [(1,2),(2,2),(3,4),(4,4),(5,4),(7,0),(8,0)] >>> contiguousGroupOn id [(1,2),(2,2),(3,4),(4,4),(5,4),(7,0),(8,0)]
[(1,2) :| [(2,2)],(3,4) :| [(4,4),(5,4)],(7,0) :| [(8,0)]] [(1,2) :| [(2,2)],(3,4) :| [(4,4),(5,4)],(7,0) :| [(8,0)]]
-} -}
contiguousGroupOn :: (a -> (Int, Int)) -> [a] -> [NonEmpty a] contiguousGroupOn :: (a -> (UInt, UInt)) -> [a] -> [NonEmpty a]
contiguousGroupOn toLineCol = foldr step [] contiguousGroupOn toLineCol = foldr step []
where where
step a [] = [pure a] step a [] = [pure a]

4
plugins/hls-explicit-imports-plugin/test/Main.hs
View File

@ -84,6 +84,6 @@ testDataDir = "test" </> "testdata"
pointRange :: Int -> Int -> Range pointRange :: Int -> Int -> Range
pointRange pointRange
(subtract 1 -> line) (subtract 1 -> fromIntegral -> line)
(subtract 1 -> col) = (subtract 1 -> fromIntegral -> col) =
Range (Position line col) (Position line $ col + 1) Range (Position line col) (Position line $ col + 1)

4
plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs
View File

@ -79,12 +79,12 @@ provider ideState typ contents fp fo = withIndefiniteProgress title Cancellable
where where
fp' = fromNormalizedFilePath fp fp' = fromNormalizedFilePath fp
title = "Formatting " <> T.pack (takeFileName fp') title = "Formatting " <> T.pack (takeFileName fp')
lspPrinterOpts = mempty{poIndentation = Just $ fo ^. tabSize} lspPrinterOpts = mempty{poIndentation = Just $ fromIntegral $ fo ^. tabSize}
region = case typ of region = case typ of
FormatText -> FormatText ->
RegionIndices Nothing Nothing RegionIndices Nothing Nothing
FormatRange (Range (Position sl _) (Position el _)) -> FormatRange (Range (Position sl _) (Position el _)) ->
RegionIndices (Just $ sl + 1) (Just $ el + 1) RegionIndices (Just $ fromIntegral $ sl + 1) (Just $ fromIntegral $ el + 1)
convertDynFlags :: DynFlags -> IO [DynOption] convertDynFlags :: DynFlags -> IO [DynOption]
convertDynFlags df = convertDynFlags df =

4
plugins/hls-haddock-comments-plugin/test/Main.hs
View File

@ -35,7 +35,7 @@ tests =
expectedNothing "StaleRecord" Record 3 12 expectedNothing "StaleRecord" Record 3 12
] ]
goldenWithHaddockComments :: FilePath -> GenCommentsType -> Int -> Int -> TestTree goldenWithHaddockComments :: FilePath -> GenCommentsType -> UInt -> UInt -> TestTree
goldenWithHaddockComments fp (toTitle -> expectedTitle) l c = goldenWithHaddockComments fp (toTitle -> expectedTitle) l c =
goldenWithHaskellDoc haddockCommentsPlugin (fp <> " (golden)") testDataDir fp "expected" "hs" $ \doc -> do goldenWithHaskellDoc haddockCommentsPlugin (fp <> " (golden)") testDataDir fp "expected" "hs" $ \doc -> do
actions <- getCodeActions doc (Range (Position l c) (Position l $ succ c)) actions <- getCodeActions doc (Range (Position l c) (Position l $ succ c))
@ -43,7 +43,7 @@ goldenWithHaddockComments fp (toTitle -> expectedTitle) l c =
Just (InR x) -> executeCodeAction x Just (InR x) -> executeCodeAction x
_ -> liftIO $ assertFailure "Unable to find CodeAction" _ -> liftIO $ assertFailure "Unable to find CodeAction"
expectedNothing :: FilePath -> GenCommentsType -> Int -> Int -> TestTree expectedNothing :: FilePath -> GenCommentsType -> UInt -> UInt -> TestTree
expectedNothing fp (toTitle -> expectedTitle) l c = testCase fp $ expectedNothing fp (toTitle -> expectedTitle) l c = testCase fp $
runSessionWithServer haddockCommentsPlugin testDataDir $ do runSessionWithServer haddockCommentsPlugin testDataDir $ do
doc <- openDoc (fp <.> "hs") "haskell" doc <- openDoc (fp <.> "hs") "haskell"

12
plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs
View File

@ -228,11 +228,11 @@ rules plugin = do
srcSpanToRange :: SrcSpan -> LSP.Range srcSpanToRange :: SrcSpan -> LSP.Range
srcSpanToRange (RealSrcSpan span _) = Range { srcSpanToRange (RealSrcSpan span _) = Range {
_start = LSP.Position { _start = LSP.Position {
_line = srcSpanStartLine span - 1 _line = fromIntegral $ srcSpanStartLine span - 1
, _character = srcSpanStartCol span - 1} , _character = fromIntegral $ srcSpanStartCol span - 1}
, _end = LSP.Position { , _end = LSP.Position {
_line = srcSpanEndLine span - 1 _line = fromIntegral $ srcSpanEndLine span - 1
, _character = srcSpanEndCol span - 1} , _character = fromIntegral $ srcSpanEndCol span - 1}
} }
srcSpanToRange (UnhelpfulSpan _) = noRange srcSpanToRange (UnhelpfulSpan _) = noRange
@ -431,7 +431,7 @@ mkSuppressHintTextEdits :: DynFlags -> T.Text -> T.Text -> [LSP.TextEdit]
mkSuppressHintTextEdits dynFlags fileContents hint = mkSuppressHintTextEdits dynFlags fileContents hint =
let let
NextPragmaInfo{ nextPragmaLine, lineSplitTextEdits } = getNextPragmaInfo dynFlags (Just fileContents) NextPragmaInfo{ nextPragmaLine, lineSplitTextEdits } = getNextPragmaInfo dynFlags (Just fileContents)
nextPragmaLinePosition = Position nextPragmaLine 0 nextPragmaLinePosition = Position (fromIntegral nextPragmaLine) 0
nextPragmaRange = Range nextPragmaLinePosition nextPragmaLinePosition nextPragmaRange = Range nextPragmaLinePosition nextPragmaLinePosition
wnoUnrecognisedPragmasText = wnoUnrecognisedPragmasText =
if wopt Opt_WarnUnrecognisedPragmas dynFlags if wopt Opt_WarnUnrecognisedPragmas dynFlags
@ -574,7 +574,7 @@ applyHint ide nfp mhint =
filterIdeas (OneHint (Position l c) title) ideas = filterIdeas (OneHint (Position l c) title) ideas =
let title' = T.unpack title let title' = T.unpack title
ideaPos = (srcSpanStartLine &&& srcSpanStartCol) . toRealSrcSpan . ideaSpan ideaPos = (srcSpanStartLine &&& srcSpanStartCol) . toRealSrcSpan . ideaSpan
in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas in filter (\i -> ideaHint i == title' && ideaPos i == (fromIntegral $ l+1, fromIntegral $ c+1)) ideas
toRealSrcSpan (RealSrcSpan real _) = real toRealSrcSpan (RealSrcSpan real _) = real
toRealSrcSpan (UnhelpfulSpan x) = error $ "No real source span: " ++ show x toRealSrcSpan (UnhelpfulSpan x) = error $ "No real source span: " ++ show x

4
plugins/hls-hlint-plugin/test/Main.hs
View File

@ -361,8 +361,8 @@ makePoint line column
pointToRange :: Point -> Range pointToRange :: Point -> Range
pointToRange Point {..} pointToRange Point {..}
| line <- subtract 1 line | line <- fromIntegral $ subtract 1 line
, column <- subtract 1 column = , column <- fromIntegral $ subtract 1 column =
Range (Position line column) (Position line $ column + 1) Range (Position line column) (Position line $ column + 1)
getCodeActionTitle :: (Command |? CodeAction) -> Maybe T.Text getCodeActionTitle :: (Command |? CodeAction) -> Maybe T.Text

4
plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs
View File

@ -11,7 +11,7 @@ import Control.Exception (try)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import qualified Data.Text as T import qualified Data.Text as T
import Development.IDE hiding (pluginHandlers) import Development.IDE hiding (pluginHandlers)
import Development.IDE.GHC.Compat (moduleNameString, hsc_dflags) import Development.IDE.GHC.Compat (hsc_dflags, moduleNameString)
import qualified Development.IDE.GHC.Compat as D import qualified Development.IDE.GHC.Compat as D
import qualified Development.IDE.GHC.Compat.Util as S import qualified Development.IDE.GHC.Compat.Util as S
import GHC.LanguageExtensions.Type import GHC.LanguageExtensions.Type
@ -50,7 +50,7 @@ provider ideState typ contents fp _ = withIndefiniteProgress title Cancellable $
case typ of case typ of
FormatText -> ret <$> fmt contents (mkConf fileOpts fullRegion) FormatText -> ret <$> fmt contents (mkConf fileOpts fullRegion)
FormatRange (Range (Position sl _) (Position el _)) -> FormatRange (Range (Position sl _) (Position el _)) ->
ret <$> fmt contents (mkConf fileOpts (rangeRegion sl el)) ret <$> fmt contents (mkConf fileOpts (rangeRegion (fromIntegral sl) (fromIntegral el)))
where where
title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp) title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp)

2
plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs
View File

@ -104,7 +104,7 @@ pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdit
where where
render (OptGHC x) = "{-# OPTIONS_GHC -Wno-" <> x <> " #-}\n" render (OptGHC x) = "{-# OPTIONS_GHC -Wno-" <> x <> " #-}\n"
render (LangExt x) = "{-# LANGUAGE " <> x <> " #-}\n" render (LangExt x) = "{-# LANGUAGE " <> x <> " #-}\n"
pragmaInsertPosition = Position nextPragmaLine 0 pragmaInsertPosition = Position (fromIntegral nextPragmaLine) 0
pragmaInsertRange = Range pragmaInsertPosition pragmaInsertPosition pragmaInsertRange = Range pragmaInsertPosition pragmaInsertPosition
-- workaround the fact that for some reason lsp-test applies text -- workaround the fact that for some reason lsp-test applies text
-- edits in reverse order than lsp (tried in both coc.nvim and vscode) -- edits in reverse order than lsp (tried in both coc.nvim and vscode)

2
plugins/hls-pragmas-plugin/test/Main.hs
View File

@ -111,7 +111,7 @@ completionTests =
, completionTest "completes No- language extensions" "Completion.hs" "NoOverload" "NoOverloadedStrings" Nothing Nothing Nothing [0, 13, 0, 31, 0, 23] , completionTest "completes No- language extensions" "Completion.hs" "NoOverload" "NoOverloadedStrings" Nothing Nothing Nothing [0, 13, 0, 31, 0, 23]
] ]
completionTest :: String -> String -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> [Int] -> TestTree completionTest :: String -> String -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> [UInt] -> TestTree
completionTest testComment fileName te' label textFormat insertText detail [a, b, c, d, x, y] = completionTest testComment fileName te' label textFormat insertText detail [a, b, c, d, x, y] =
testCase testComment $ runSessionWithServer pragmasPlugin testDataDir $ do testCase testComment $ runSessionWithServer pragmasPlugin testDataDir $ do
doc <- openDoc fileName "haskell" doc <- openDoc fileName "haskell"

2
plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs
View File

@ -167,7 +167,7 @@ realSrcSpanToIdentifierSpan realSrcSpan
identifierSpanToRange :: IdentifierSpan -> Range identifierSpanToRange :: IdentifierSpan -> Range
identifierSpanToRange (IdentifierSpan line startCol endCol) = identifierSpanToRange (IdentifierSpan line startCol endCol) =
Range (Position line startCol) (Position line endCol) Range (Position (fromIntegral line) (fromIntegral startCol)) (Position (fromIntegral line) (fromIntegral endCol))
data UsedIdentifier = UsedIdentifier { data UsedIdentifier = UsedIdentifier {
usedIdentifierName :: !Name, usedIdentifierName :: !Name,

4
plugins/hls-qualify-imported-names-plugin/test/Main.hs
View File

@ -140,7 +140,7 @@ goldenWithQualifyImportedNames testName path =
pointToRange :: Point -> Range pointToRange :: Point -> Range
pointToRange Point {..} pointToRange Point {..}
| line <- subtract 1 line | line <- fromIntegral $ subtract 1 line
, column <- subtract 1 column = , column <- fromIntegral $ subtract 1 column =
Range (Position line column) (Position line $ column + 1) Range (Position line column) (Position line $ column + 1)

4
plugins/hls-refine-imports-plugin/test/Main.hs
View File

@ -74,6 +74,6 @@ testDataDir = "test" </> "testdata"
pointRange :: Int -> Int -> Range pointRange :: Int -> Int -> Range
pointRange pointRange
(subtract 1 -> line) (subtract 1 -> fromIntegral -> line)
(subtract 1 -> col) = (subtract 1 -> fromIntegral -> col) =
Range (Position line col) (Position line $ col + 1) Range (Position line col) (Position line $ col + 1)

4
plugins/hls-splice-plugin/test/Main.hs
View File

@ -83,7 +83,7 @@ goldenTestWithEdit fp tc line col =
theRange = theRange =
Range Range
{ _start = Position 0 0 { _start = Position 0 0
, _end = Position (length lns + 1) 1 , _end = Position (fromIntegral $ length lns + 1) 1
} }
waitForAllProgressDone -- cradle waitForAllProgressDone -- cradle
waitForAllProgressDone waitForAllProgressDone
@ -104,7 +104,7 @@ testDataDir :: FilePath
testDataDir = "test" </> "testdata" testDataDir = "test" </> "testdata"
pointRange :: Int -> Int -> Range pointRange :: Int -> Int -> Range
pointRange (subtract 1 -> line) (subtract 1 -> col) = pointRange (subtract 1 -> fromIntegral -> line) (subtract 1 -> fromIntegral -> col) =
Range (Position line col) (Position line $ col + 1) Range (Position line col) (Position line $ col + 1)
-- | Get the title of a code action. -- | Get the title of a code action.

5
plugins/hls-tactics-plugin/src/Wingman/Range.hs
View File

@ -19,6 +19,5 @@ rangeToSrcSpan file range = RealSrcSpan (rangeToRealSrcSpan file range) Nothing
rangeToRealSrcSpan :: String -> Range -> RealSrcSpan rangeToRealSrcSpan :: String -> Range -> RealSrcSpan
rangeToRealSrcSpan file (Range (Position startLn startCh) (Position endLn endCh)) = rangeToRealSrcSpan file (Range (Position startLn startCh) (Position endLn endCh)) =
mkRealSrcSpan mkRealSrcSpan
(mkRealSrcLoc (FS.fsLit file) (startLn + 1) (startCh + 1)) (mkRealSrcLoc (FS.fsLit file) (fromIntegral $ startLn + 1) (fromIntegral $ startCh + 1))
(mkRealSrcLoc (FS.fsLit file) (endLn + 1) (endCh + 1)) (mkRealSrcLoc (FS.fsLit file) (fromIntegral $ endLn + 1) (fromIntegral $ endCh + 1))

4
plugins/hls-tactics-plugin/test/Utils.hs
View File

@ -42,8 +42,8 @@ plugin = Tactic.descriptor "tactics"
-- NB: These coordinates are in "file space", ie, 1-indexed. -- NB: These coordinates are in "file space", ie, 1-indexed.
pointRange :: Int -> Int -> Range pointRange :: Int -> Int -> Range
pointRange pointRange
(subtract 1 -> line) (subtract 1 -> fromIntegral -> line)
(subtract 1 -> col) = (subtract 1 -> fromIntegral -> col) =
Range (Position line col) (Position line $ col + 1) Range (Position line col) (Position line $ col + 1)

6
stack-8.10.6.yaml
View File

@ -44,9 +44,9 @@ extra-deps:
- hiedb-0.4.1.0 - hiedb-0.4.1.0
- implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998 - implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998
- implicit-hie-cradle-0.3.0.5@sha256:5f5e575f549b2a9db664be7650b5c3c9226e313bddc46c79e2e83eb349f8e692,2610 - implicit-hie-cradle-0.3.0.5@sha256:5f5e575f549b2a9db664be7650b5c3c9226e313bddc46c79e2e83eb349f8e692,2610
- lsp-1.2.0.1@sha256:5b37d26fcbf037434e257e953c08513d4cb125ed784d4611038905c72dc0f58c,5431 - lsp-1.4.0.0
- lsp-test-0.14.0.1@sha256:efce2ddec4183390341db7667e63936954c654a14d809ad7b61e4010a2fde97e,4739 - lsp-test-0.14.0.2
- lsp-types-1.3.0.1@sha256:1dc41eb358345c1927fb8f285e7d951869623fe5b695fbbecf2fe6a3cee9fcfd,4646 - lsp-types-1.4.0.0
- monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900 - monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900
- optparse-applicative-0.15.1.0@sha256:29ff6146aabf54d46c4c8788e8d1eadaea27c94f6d360c690c5f6c93dac4b07e,4810 - optparse-applicative-0.15.1.0@sha256:29ff6146aabf54d46c4c8788e8d1eadaea27c94f6d360c690c5f6c93dac4b07e,4810
- refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663 - refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663

6
stack-8.10.7.yaml
View File

@ -45,9 +45,9 @@ extra-deps:
- hiedb-0.4.1.0 - hiedb-0.4.1.0
- implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998 - implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998
- implicit-hie-cradle-0.3.0.5@sha256:5f5e575f549b2a9db664be7650b5c3c9226e313bddc46c79e2e83eb349f8e692,2610 - implicit-hie-cradle-0.3.0.5@sha256:5f5e575f549b2a9db664be7650b5c3c9226e313bddc46c79e2e83eb349f8e692,2610
- lsp-1.2.0.1@sha256:5b37d26fcbf037434e257e953c08513d4cb125ed784d4611038905c72dc0f58c,5431 - lsp-1.4.0.0
- lsp-test-0.14.0.1@sha256:efce2ddec4183390341db7667e63936954c654a14d809ad7b61e4010a2fde97e,4739 - lsp-test-0.14.0.2
- lsp-types-1.3.0.1@sha256:1dc41eb358345c1927fb8f285e7d951869623fe5b695fbbecf2fe6a3cee9fcfd,4646 - lsp-types-1.4.0.0
- monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900 - monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900
- optparse-applicative-0.15.1.0@sha256:29ff6146aabf54d46c4c8788e8d1eadaea27c94f6d360c690c5f6c93dac4b07e,4810 - optparse-applicative-0.15.1.0@sha256:29ff6146aabf54d46c4c8788e8d1eadaea27c94f6d360c690c5f6c93dac4b07e,4810
- refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663 - refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663

8
stack-8.6.5.yaml
View File

@ -103,9 +103,11 @@ extra-deps:
- some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055
- unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082
- resourcet-1.2.3 - resourcet-1.2.3
- lsp-1.2.0.1 - lsp-1.4.0.0
- lsp-types-1.3.0.1 - lsp-test-0.14.0.2
- lsp-test-0.14.0.1 - lsp-types-1.4.0.0
- mod-0.1.2.2
- semirings-0.6
- stm-containers-1.1.0.4 - stm-containers-1.1.0.4
- stm-hamt-1.2.0.6@sha256:fba86ccb4b45c5706c19b0e1315ba63dcac3b5d71de945ec001ba921fae80061,3972 - stm-hamt-1.2.0.6@sha256:fba86ccb4b45c5706c19b0e1315ba63dcac3b5d71de945ec001ba921fae80061,3972
- primitive-extras-0.10.1 - primitive-extras-0.10.1

6
stack-8.8.4.yaml
View File

@ -79,9 +79,9 @@ extra-deps:
- constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853
- some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055
- unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082
- lsp-1.2.0.1 - lsp-1.4.0.0
- lsp-types-1.3.0.1 - lsp-test-0.14.0.2
- lsp-test-0.14.0.1 - lsp-types-1.4.0.0
- stm-containers-1.1.0.4 - stm-containers-1.1.0.4
- stm-hamt-1.2.0.6@sha256:fba86ccb4b45c5706c19b0e1315ba63dcac3b5d71de945ec001ba921fae80061,3972 - stm-hamt-1.2.0.6@sha256:fba86ccb4b45c5706c19b0e1315ba63dcac3b5d71de945ec001ba921fae80061,3972
- primitive-extras-0.10.1 - primitive-extras-0.10.1

6
stack-9.0.1.yaml
View File

@ -45,9 +45,9 @@ extra-deps:
- implicit-hie-cradle-0.3.0.5 - implicit-hie-cradle-0.3.0.5
- monad-dijkstra-0.1.1.3 - monad-dijkstra-0.1.1.3
- retrie-1.1.0.0 - retrie-1.1.0.0
- lsp-1.2.0.1 - lsp-1.4.0.0
- lsp-types-1.3.0.1 - lsp-test-0.14.0.2
- lsp-test-0.14.0.1 - lsp-types-1.4.0.0
# shake-bench dependencies # shake-bench dependencies
- Chart-1.9.3 - Chart-1.9.3

6
stack.yaml
View File

@ -45,9 +45,9 @@ extra-deps:
- hiedb-0.4.1.0 - hiedb-0.4.1.0
- implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998 - implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998
- implicit-hie-cradle-0.3.0.5@sha256:5f5e575f549b2a9db664be7650b5c3c9226e313bddc46c79e2e83eb349f8e692,2610 - implicit-hie-cradle-0.3.0.5@sha256:5f5e575f549b2a9db664be7650b5c3c9226e313bddc46c79e2e83eb349f8e692,2610
- lsp-1.2.0.1@sha256:5b37d26fcbf037434e257e953c08513d4cb125ed784d4611038905c72dc0f58c,5431 - lsp-1.4.0.0
- lsp-test-0.14.0.1@sha256:efce2ddec4183390341db7667e63936954c654a14d809ad7b61e4010a2fde97e,4739 - lsp-test-0.14.0.2
- lsp-types-1.3.0.1@sha256:1dc41eb358345c1927fb8f285e7d951869623fe5b695fbbecf2fe6a3cee9fcfd,4646 - lsp-types-1.4.0.0
- monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900 - monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900
- optparse-applicative-0.15.1.0@sha256:29ff6146aabf54d46c4c8788e8d1eadaea27c94f6d360c690c5f6c93dac4b07e,4810 - optparse-applicative-0.15.1.0@sha256:29ff6146aabf54d46c4c8788e8d1eadaea27c94f6d360c690c5f6c93dac4b07e,4810
- refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663 - refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663

8
test/functional/Completion.hs
View File

@ -46,10 +46,10 @@ tests = testGroup "completions" [
resolved ^. insertTextFormat @?= Just Snippet resolved ^. insertTextFormat @?= Just Snippet
resolved ^. insertText @?= Just "putStrLn ${1:String}" resolved ^. insertText @?= Just "putStrLn ${1:String}"
, testCase "completes imports" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do , testCase "completes imports" $ runSession (hlsCommand <> " --test") fullCaps "test/testdata/completion" $ do
doc <- openDoc "Completion.hs" "haskell" doc <- openDoc "Completion.hs" "haskell"
_ <- waitForDiagnostics waitForKickDone
let te = TextEdit (Range (Position 1 17) (Position 1 26)) "Data.M" let te = TextEdit (Range (Position 1 17) (Position 1 26)) "Data.M"
_ <- applyEdit doc te _ <- applyEdit doc te
@ -61,10 +61,10 @@ tests = testGroup "completions" [
item ^. detail @?= Just "Data.Maybe" item ^. detail @?= Just "Data.Maybe"
item ^. kind @?= Just CiModule item ^. kind @?= Just CiModule
, testCase "completes qualified imports" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do , testCase "completes qualified imports" $ runSession (hlsCommand <> " --test") fullCaps "test/testdata/completion" $ do
doc <- openDoc "Completion.hs" "haskell" doc <- openDoc "Completion.hs" "haskell"
_ <- waitForDiagnostics _ <- waitForKickDone
let te = TextEdit (Range (Position 2 17) (Position 2 25)) "Data.L" let te = TextEdit (Range (Position 2 17) (Position 2 25)) "Data.L"
_ <- applyEdit doc te _ <- applyEdit doc te

2
test/functional/Progress.hs
View File

@ -57,7 +57,7 @@ formatLspConfig :: Value -> Value
formatLspConfig provider = object ["haskell" .= object ["formattingProvider" .= (provider :: Value)]] formatLspConfig provider = object ["haskell" .= object ["formattingProvider" .= (provider :: Value)]]
progressCaps :: ClientCapabilities progressCaps :: ClientCapabilities
progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True))} progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True) Nothing Nothing)}
data CollectedProgressNotification data CollectedProgressNotification
= CreateM WorkDoneProgressCreateParams = CreateM WorkDoneProgressCreateParams

2
test/functional/TypeDefinition.hs
View File

@ -37,7 +37,7 @@ getTypeDefinitionTest (symbolFile, symbolLine, symbolCol) definitionLocations =
InL defs <- getTypeDefinitions doc $ Position symbolLine symbolCol InL defs <- getTypeDefinitions doc $ Position symbolLine symbolCol
liftIO $ defs `expectSameLocations` map (first3 (definitionsPath </>)) definitionLocations liftIO $ defs `expectSameLocations` map (first3 (definitionsPath </>)) definitionLocations
getTypeDefinitionTest' :: Int -> Int -> Int -> Int -> Assertion getTypeDefinitionTest' :: UInt -> UInt -> UInt -> UInt -> Assertion
getTypeDefinitionTest' symbolLine symbolCol definitionLine definitionCol = getTypeDefinitionTest' symbolLine symbolCol definitionLine definitionCol =
getTypeDefinitionTest ("src/Lib.hs", symbolLine, symbolCol) getTypeDefinitionTest ("src/Lib.hs", symbolLine, symbolCol)
[("src/Lib.hs", definitionLine, definitionCol)] [("src/Lib.hs", definitionLine, definitionCol)]