Merge branch 'master' into alex/4057-2

Author: fendor

.github/actions/setup-build/action.yml

@@ -31,7 +31,7 @@ runs:
         sudo chown -R $USER /usr/local/.ghcup
       shell: bash
 
-    - uses: haskell-actions/[email protected].5
+    - uses: haskell-actions/[email protected].6
       id: HaskEnvSetup
       with:
         ghc-version  : ${{ inputs.ghc   }}
@@ -116,3 +116,18 @@ runs:
     - name: "Remove freeze file"
       run: rm -f cabal.project.freeze
       shell: bash
+
+    # Make sure to clear all unneeded `ghcup`` caches.
+    # At some point, we were running out of disk space, see issue
+    # https://github.com/haskell/haskell-language-server/issues/4386 for details.
+    #
+    # Using "printf" debugging (`du -sh *` and `df -h /`) and binary searching,
+    # we figured out that `ghcup` caches are taking up a sizable portion of the
+    # disk space.
+    # Thus, we remove anything we don't need, especially caches and temporary files.
+    # For got measure, we also make sure no other tooling versions are
+    # installed besides the ones we explicitly want.
+    - name: "Remove ghcup caches"
+      if: runner.os == 'Linux'
+      run: ghcup gc --ghc-old --share-dir --hls-no-ghc --cache --tmpdirs --unset
+      shell: bash

.github/workflows/bench.yml

@@ -127,7 +127,7 @@ jobs:
         example: ['cabal', 'lsp-types']
 
     steps:
-    - uses: haskell-actions/[email protected].3
+    - uses: haskell-actions/[email protected].6
       with:
         ghc-version  : ${{ matrix.ghc   }}
         cabal-version: ${{ matrix.cabal }}

cabal.project

@@ -7,7 +7,8 @@ packages:
          ./hls-plugin-api
          ./hls-test-utils
 
-index-state: 2024-06-29T00:00:00Z
+
+index-state:  2024-08-22T00:00:00Z
 
 tests: True
 test-show-details: direct

exe/Wrapper.hs

@@ -9,7 +9,6 @@ module Main where
 
 import           Control.Monad.Extra
 import           Data.Default
-import           Data.Either.Extra                  (eitherToMaybe)
 import           Data.Foldable
 import           Data.List
 import           Data.List.Extra                    (trimEnd)
@@ -76,8 +75,11 @@ main = do
           putStrLn $ showProgramVersionOfInterest programsOfInterest
           putStrLn "Tool versions in your project"
           cradle <- findProjectCradle' recorder False
-          ghcVersion <- runExceptT $ getRuntimeGhcVersion' cradle
-          putStrLn $ showProgramVersion "ghc" $ mkVersion =<< eitherToMaybe ghcVersion
+          runExceptT (getRuntimeGhcVersion' cradle) >>= \case
+            Left err ->
+              T.hPutStrLn stderr (prettyError err NoShorten)
+            Right ghcVersion ->
+              putStrLn $ showProgramVersion "ghc" $ mkVersion ghcVersion
 
       VersionMode PrintVersion ->
           putStrLn hlsVer

ghcide/src/Development/IDE/Core/Actions.hs

@@ -66,56 +66,59 @@ getAtPoint file pos = runMaybeT $ do
   !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
   MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos'
 
--- | For each Location, determine if we have the PositionMapping
--- for the correct file. If not, get the correct position mapping
--- and then apply the position mapping to the location.
-toCurrentLocations
+-- | Converts locations in the source code to their current positions,
+-- taking into account changes that may have occurred due to edits.
+toCurrentLocation
   :: PositionMapping
   -> NormalizedFilePath
-  -> [Location]
-  -> IdeAction [Location]
-toCurrentLocations mapping file = mapMaybeM go
+  -> Location
+  -> IdeAction (Maybe Location)
+toCurrentLocation mapping file (Location uri range) =
+  -- The Location we are going to might be in a different
+  -- file than the one we are calling gotoDefinition from.
+  -- So we check that the location file matches the file
+  -- we are in.
+  if nUri == normalizedFilePathToUri file
+  -- The Location matches the file, so use the PositionMapping
+  -- we have.
+  then pure $ Location uri <$> toCurrentRange mapping range
+  -- The Location does not match the file, so get the correct
+  -- PositionMapping and use that instead.
+  else do
+    otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do
+      otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri
+      useWithStaleFastMT GetHieAst otherLocationFile
+    pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping)
   where
-    go :: Location -> IdeAction (Maybe Location)
-    go (Location uri range) =
-      -- The Location we are going to might be in a different
-      -- file than the one we are calling gotoDefinition from.
-      -- So we check that the location file matches the file
-      -- we are in.
-      if nUri == normalizedFilePathToUri file
-      -- The Location matches the file, so use the PositionMapping
-      -- we have.
-      then pure $ Location uri <$> toCurrentRange mapping range
-      -- The Location does not match the file, so get the correct
-      -- PositionMapping and use that instead.
-      else do
-        otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do
-          otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri
-          useWithStaleFastMT GetHieAst otherLocationFile
-        pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping)
-      where
-        nUri :: NormalizedUri
-        nUri = toNormalizedUri uri
+    nUri :: NormalizedUri
+    nUri = toNormalizedUri uri
 
 -- | Goto Definition.
-getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
+getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)])
 getDefinition file pos = runMaybeT $ do
     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
     (HAR _ hf _ _ _, mapping) <- useWithStaleFastMT GetHieAst file
     (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file
     !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)
-    locations <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'
-    MaybeT $ Just <$> toCurrentLocations mapping file locations
+    locationsWithIdentifier <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'
+    mapMaybeM (\(location, identifier) -> do
+      fixedLocation <- MaybeT $ toCurrentLocation mapping file location
+      pure $ Just (fixedLocation, identifier)
+      ) locationsWithIdentifier
 
-getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
+
+getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)])
 getTypeDefinition file pos = runMaybeT $ do
     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
     (hf, mapping) <- useWithStaleFastMT GetHieAst file
     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
-    locations <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'
-    MaybeT $ Just <$> toCurrentLocations mapping file locations
+    locationsWithIdentifier <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'
+    mapMaybeM (\(location, identifier) -> do
+      fixedLocation <- MaybeT $ toCurrentLocation mapping file location
+      pure $ Just (fixedLocation, identifier)
+      ) locationsWithIdentifier
 
 highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
 highlightAtPoint file pos = runMaybeT $ do

ghcide/src/Development/IDE/GHC/Compat/Core.hs

@@ -633,6 +633,8 @@ instance HasSrcSpan (EpAnn a) where
 #if MIN_VERSION_ghc(9,9,0)
 instance HasSrcSpan (SrcLoc.GenLocated (EpAnn ann) a) where
   getLoc (L l _) = getLoc l
+instance HasSrcSpan (SrcLoc.GenLocated (GHC.EpaLocation) a) where
+  getLoc = GHC.getHasLoc
 #else
 instance HasSrcSpan (SrcSpanAnn' ann) where
   getLoc = GHC.locA

ghcide/src/Development/IDE/GHC/Orphans.hs

@@ -226,6 +226,12 @@ instance NFData (HsExpr (GhcPass Renamed)) where
 instance NFData (Pat (GhcPass Renamed)) where
     rnf = rwhnf
 
+instance NFData (HsExpr (GhcPass Typechecked)) where
+    rnf = rwhnf
+
+instance NFData (Pat (GhcPass Typechecked)) where
+    rnf = rwhnf
+
 instance NFData Extension where
   rnf = rwhnf
 

ghcide/src/Development/IDE/LSP/HoverDefinition.hs

@@ -47,8 +47,8 @@ gotoDefinition     :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPos
 hover              :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (Hover |? Null)
 gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentTypeDefinition)
 documentHighlight  :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) ([DocumentHighlight] |? Null)
-gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR)
-gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR)
+gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR . map fst)
+gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR . map fst)
 hover          = request "Hover"      getAtPoint     (InR Null)     foundHover
 documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL
 

ghcide/src/Development/IDE/Spans/AtPoint.hs

@@ -179,14 +179,15 @@ documentHighlight hf rf pos = pure highlights
         then DocumentHighlightKind_Write
         else DocumentHighlightKind_Read
 
+-- | Locate the type definition of the name at a given position.
 gotoTypeDefinition
   :: MonadIO m
   => WithHieDb
   -> LookupModule m
   -> IdeOptions
   -> HieAstResult
   -> Position
-  -> MaybeT m [Location]
+  -> MaybeT m [(Location, Identifier)]
 gotoTypeDefinition withHieDb lookupModule ideOpts srcSpans pos
   = lift $ typeLocationsAtPoint withHieDb lookupModule ideOpts pos srcSpans
 
@@ -199,7 +200,7 @@ gotoDefinition
   -> M.Map ModuleName NormalizedFilePath
   -> HieASTs a
   -> Position
-  -> MaybeT m [Location]
+  -> MaybeT m [(Location, Identifier)]
 gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos
   = lift $ locationsAtPoint withHieDb getHieFile ideOpts imports pos srcSpans
 
@@ -306,6 +307,7 @@ atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env
             UnhelpfulLoc {} | isInternalName name || isSystemName name -> Nothing
             _ -> Just $ "*Defined " <> printOutputable (pprNameDefnLoc name) <> "*"
 
+-- | Find 'Location's of type definition at a specific point and return them along with their 'Identifier's.
 typeLocationsAtPoint
   :: forall m
    . MonadIO m
@@ -314,7 +316,7 @@ typeLocationsAtPoint
   -> IdeOptions
   -> Position
   -> HieAstResult
-  -> m [Location]
+  -> m [(Location, Identifier)]
 typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) =
   case hieKind of
     HieFromDisk hf ->
@@ -332,12 +334,12 @@ typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKi
             HQualTy a b -> getTypes' [a,b]
             HCastTy a -> getTypes' [a]
             _ -> []
-        in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes' ts)
+        in fmap nubOrd $ concatMapM (\n -> fmap (maybe [] (fmap (,Right n))) (nameToLocation withHieDb lookupModule n)) (getTypes' ts)
     HieFresh ->
       let ts = concat $ pointCommand ast pos getts
           getts x = nodeType ni  ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni)
             where ni = nodeInfo x
-        in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts)
+        in fmap nubOrd $ concatMapM (\n -> fmap (maybe [] (fmap (,Right n))) (nameToLocation withHieDb lookupModule n)) (getTypes ts)
 
 namesInType :: Type -> [Name]
 namesInType (TyVarTy n)      = [varName n]
@@ -352,6 +354,7 @@ namesInType _                = []
 getTypes :: [Type] -> [Name]
 getTypes ts = concatMap namesInType ts
 
+-- | Find 'Location's of definition at a specific point and return them along with their 'Identifier's.
 locationsAtPoint
   :: forall m a
    . MonadIO m
@@ -361,13 +364,16 @@ locationsAtPoint
   -> M.Map ModuleName NormalizedFilePath
   -> Position
   -> HieASTs a
-  -> m [Location]
+  -> m [(Location, Identifier)]
 locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast =
   let ns = concat $ pointCommand ast pos (M.keys . getNodeIds)
       zeroPos = Position 0 0
       zeroRange = Range zeroPos zeroPos
-      modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports
-    in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation withHieDb lookupModule) ns
+      modToLocation m = fmap (\fs -> pure (Location (fromNormalizedUri $ filePathToUri' fs) zeroRange)) $ M.lookup m imports
+   in fmap (nubOrd . concat) $ mapMaybeM
+        (either (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m)))
+                (\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n)))
+        ns
 
 -- | Given a 'Name' attempt to find the location where it is defined.
 nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location])

haskell-language-server.cabal

@@ -248,8 +248,10 @@ library hls-cabal-plugin
     Ide.Plugin.Cabal.Completion.Completions
     Ide.Plugin.Cabal.Completion.Data
     Ide.Plugin.Cabal.Completion.Types
+    Ide.Plugin.Cabal.Definition
     Ide.Plugin.Cabal.FieldSuggest
     Ide.Plugin.Cabal.LicenseSuggest
+    Ide.Plugin.Cabal.CabalAdd
     Ide.Plugin.Cabal.Orphans
     Ide.Plugin.Cabal.Outline
     Ide.Plugin.Cabal.Parse
@@ -277,6 +279,12 @@ library hls-cabal-plugin
     , transformers
     , unordered-containers  >=0.2.10.0
     , containers
+    , cabal-add
+    , process
+    , aeson
+    , Cabal
+    , pretty
+
   hs-source-dirs:   plugins/hls-cabal-plugin/src
 
 test-suite hls-cabal-plugin-tests
@@ -287,10 +295,12 @@ test-suite hls-cabal-plugin-tests
   hs-source-dirs:   plugins/hls-cabal-plugin/test
   main-is:          Main.hs
   other-modules:
+    CabalAdd
     Completer
     Context
-    Utils
+    Definition
     Outline
+    Utils
   build-depends:
     , base
     , bytestring
@@ -303,6 +313,7 @@ test-suite hls-cabal-plugin-tests
     , lens
     , lsp-types
     , text
+    , hls-plugin-api
 
 -----------------------------
 -- class plugin
@@ -1361,6 +1372,7 @@ test-suite hls-explicit-record-fields-plugin-tests
     , base
     , filepath
     , text
+    , ghcide
     , haskell-language-server:hls-explicit-record-fields-plugin
     , hls-test-utils              == 2.9.0.1