diff --git a/.github/actions/setup-build/action.yml b/.github/actions/setup-build/action.yml index 26a094674e..ca3a290b83 100644 --- a/.github/actions/setup-build/action.yml +++ b/.github/actions/setup-build/action.yml @@ -31,7 +31,7 @@ runs: sudo chown -R $USER /usr/local/.ghcup shell: bash - - uses: haskell-actions/setup@v2.7.5 + - uses: haskell-actions/setup@v2.7.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 diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index f3834cac6c..99b25adf7a 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -127,7 +127,7 @@ jobs: example: ['cabal', 'lsp-types'] steps: - - uses: haskell-actions/setup@v2.7.3 + - uses: haskell-actions/setup@v2.7.6 with: ghc-version : ${{ matrix.ghc }} cabal-version: ${{ matrix.cabal }} diff --git a/cabal.project b/cabal.project index dc7887ee7a..bacb35e745 100644 --- a/cabal.project +++ b/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 diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 3b80f37c49..2c2401ab6a 100644 --- a/exe/Wrapper.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 4c808f21d9..20c86c8280 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 15ce2f4412..c6d4bc84bc 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 3572662356..8d46d44445 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index aea3449bf3..e4c20504e4 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 434c684b96..88c6570b23 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -179,6 +179,7 @@ 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 @@ -186,7 +187,7 @@ gotoTypeDefinition -> 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]) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index ad46096dee..447882a61e 100644 --- a/haskell-language-server.cabal +++ b/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 diff --git a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs index 7b1887a802..6c4b4041c9 100644 --- a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs +++ b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs @@ -13,6 +13,7 @@ module Ide.Plugin.RangeMap fromList, fromList', filterByRange, + elementsInRange, ) where import Development.IDE.Graph.Classes (NFData) @@ -67,6 +68,14 @@ filterByRange range = map snd . IM.dominators (rangeToInterval range) . unRangeM filterByRange range = map snd . filter (isSubrangeOf range . fst) . unRangeMap #endif +-- | Extracts all elements from a 'RangeMap' that fall within a given 'Range'. +elementsInRange :: Range -> RangeMap a -> [a] +#ifdef USE_FINGERTREE +elementsInRange range = map snd . IM.intersections (rangeToInterval range) . unRangeMap +#else +elementsInRange range = map snd . filter (flip isSubrangeOf range . fst) . unRangeMap +#endif + #ifdef USE_FINGERTREE -- NOTE(ozkutuk): In itself, this conversion is wrong. As Michael put it: -- "LSP Ranges have exclusive upper bounds, whereas the intervals here are diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index f8b7cfe717..6372480ffe 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -4,7 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} -module Ide.Plugin.Cabal (descriptor, Log (..)) where +module Ide.Plugin.Cabal (descriptor, haskellInteractionDescriptor, Log (..)) where import Control.Concurrent.Strict import Control.DeepSeq @@ -37,6 +37,7 @@ import Ide.Plugin.Cabal.Completion.Types (ParseCabalCommonSe ParseCabalFields (..), ParseCabalFile (..)) import qualified Ide.Plugin.Cabal.Completion.Types as Types +import Ide.Plugin.Cabal.Definition (gotoDefinition) import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics import qualified Ide.Plugin.Cabal.FieldSuggest as FieldSuggest import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest @@ -49,6 +50,9 @@ import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types import qualified Language.LSP.VFS as VFS +import qualified Data.Text () +import qualified Ide.Plugin.Cabal.CabalAdd as CabalAdd + data Log = LogModificationTime NormalizedFilePath FileVersion | LogShake Shake.Log @@ -59,6 +63,7 @@ data Log | LogFOI (HashMap NormalizedFilePath FileOfInterestStatus) | LogCompletionContext Types.Context Position | LogCompletions Types.Log + | LogCabalAdd CabalAdd.Log deriving (Show) instance Pretty Log where @@ -82,6 +87,25 @@ instance Pretty Log where <+> "for cursor position:" <+> pretty position LogCompletions logs -> pretty logs + LogCabalAdd logs -> pretty logs + +-- | Some actions with cabal files originate from haskell files. +-- This descriptor allows to hook into the diagnostics of haskell source files, and +-- allows us to provide code actions and commands that interact with `.cabal` files. +haskellInteractionDescriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +haskellInteractionDescriptor recorder plId = + (defaultPluginDescriptor plId "Provides the cabal-add code action in haskell files") + { pluginHandlers = + mconcat + [ mkPluginHandler LSP.SMethod_TextDocumentCodeAction cabalAddCodeAction + ] + , pluginCommands = [PluginCommand CabalAdd.cabalAddCommand "add a dependency to a cabal file" (CabalAdd.command cabalAddRecorder)] + , pluginRules = pure () + , pluginNotificationHandlers = mempty + } + where + cabalAddRecorder = cmapWithPrio LogCabalAdd recorder + descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = @@ -93,6 +117,7 @@ descriptor recorder plId = , mkPluginHandler LSP.SMethod_TextDocumentCompletion $ completion recorder , mkPluginHandler LSP.SMethod_TextDocumentDocumentSymbol moduleOutline , mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ fieldSuggestCodeAction recorder + , mkPluginHandler LSP.SMethod_TextDocumentDefinition gotoDefinition ] , pluginNotificationHandlers = mconcat @@ -277,6 +302,33 @@ fieldSuggestCodeAction recorder ide _ (CodeActionParams _ _ (TextDocumentIdentif let completionTexts = fmap (^. JL.label) completions pure $ FieldSuggest.fieldErrorAction uri fieldName completionTexts _range + +cabalAddCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction +cabalAddCodeAction state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics=diags}) = do + maxCompls <- fmap maxCompletions . liftIO $ runAction "cabal.cabal-add" state getClientConfigAction + let suggestions = take maxCompls $ concatMap CabalAdd.hiddenPackageSuggestion diags + case suggestions of + [] -> pure $ InL [] + _ -> + case uriToFilePath uri of + Nothing -> pure $ InL [] + Just haskellFilePath -> do + mbCabalFile <- liftIO $ CabalAdd.findResponsibleCabalFile haskellFilePath + case mbCabalFile of + Nothing -> pure $ InL [] + Just cabalFilePath -> do + verTxtDocId <- lift $ pluginGetVersionedTextDoc $ TextDocumentIdentifier (filePathToUri cabalFilePath) + mbGPD <- liftIO $ runAction "cabal.cabal-add" state $ useWithStale ParseCabalFile $ toNormalizedFilePath cabalFilePath + case mbGPD of + Nothing -> pure $ InL [] + Just (gpd, _) -> do + actions <- liftIO $ CabalAdd.addDependencySuggestCodeAction plId verTxtDocId + suggestions + haskellFilePath cabalFilePath + gpd + pure $ InL $ fmap InR actions + + -- ---------------------------------------------------------------- -- Cabal file of Interest rules and global variable -- ---------------------------------------------------------------- diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd.hs new file mode 100644 index 0000000000..e60d06db78 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards #-} + +module Ide.Plugin.Cabal.CabalAdd +( findResponsibleCabalFile + , addDependencySuggestCodeAction + , hiddenPackageSuggestion + , cabalAddCommand + , command + , Log +) +where + +import Control.Monad (filterM, void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except +import Data.Aeson.Types (FromJSON, + ToJSON, toJSON) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.List.NonEmpty (NonEmpty (..), + fromList) +import Data.String (IsString) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Encoding as T +import Development.IDE (IdeState, + useWithStale) +import Development.IDE.Core.Rules (runAction) +import Development.IDE.Core.RuleTypes (GetFileContents (..)) +import Distribution.Client.Add as Add +import Distribution.Compat.Prelude (Generic) +import Distribution.PackageDescription (GenericPackageDescription, + packageDescription, + specVersion) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.PackageDescription.Quirks (patchQuirks) +import qualified Distribution.Pretty as Pretty +import Distribution.Simple.BuildTarget (BuildTarget, + buildTargetComponentName, + readBuildTargets) +import Distribution.Simple.Utils (safeHead) +import Distribution.Verbosity (silent, + verboseNoStderr) +import Ide.Logger +import Ide.Plugin.Cabal.Completion.Types (ParseCabalFields (..), + ParseCabalFile (..)) +import Ide.Plugin.Cabal.Orphans () +import Ide.Plugin.Error +import Ide.PluginUtils (WithDeletions (SkipDeletions), + diffText, + mkLspCommand) +import Ide.Types (CommandFunction, + CommandId (CommandId), + PluginId, + pluginGetClientCapabilities, + pluginSendRequest) +import Language.LSP.Protocol.Message (SMethod (SMethod_WorkspaceApplyEdit)) +import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), + ClientCapabilities, + CodeAction (CodeAction), + CodeActionKind (CodeActionKind_QuickFix), + Diagnostic (..), + Null (Null), + VersionedTextDocumentIdentifier, + WorkspaceEdit, + toNormalizedFilePath, + type (|?) (InR)) +import System.Directory (doesFileExist, + listDirectory) +import System.FilePath (dropFileName, + makeRelative, + splitPath, + takeExtension, + ()) +import Text.PrettyPrint (render) +import Text.Regex.TDFA + +data Log + = LogFoundResponsibleCabalFile FilePath + | LogCalledCabalAddCommand CabalAddCommandParams + | LogCreatedEdit WorkspaceEdit + | LogExecutedCommand + deriving (Show) + +instance Pretty Log where + pretty = \case + LogFoundResponsibleCabalFile fp -> "Located the responsible cabal file at " <+> pretty fp + LogCalledCabalAddCommand params -> "Called CabalAdd command with:\n" <+> pretty params + LogCreatedEdit edit -> "Created inplace edit:\n" <+> pretty edit + LogExecutedCommand -> "Executed CabalAdd command" + +cabalAddCommand :: IsString p => p +cabalAddCommand = "cabalAdd" + +data CabalAddCommandParams = + CabalAddCommandParams { cabalPath :: FilePath + , verTxtDocId :: VersionedTextDocumentIdentifier + , buildTarget :: Maybe String + , dependency :: T.Text + , version :: Maybe T.Text + } + deriving (Generic, Show) + deriving anyclass (FromJSON, ToJSON) + +instance Pretty CabalAddCommandParams where + pretty CabalAddCommandParams{..} = + "CabalAdd parameters:" <+> vcat + [ "cabal path:" <+> pretty cabalPath + , "target:" <+> pretty buildTarget + , "dependendency:" <+> pretty dependency + , "version:" <+> pretty version + ] + +-- | Creates a code action that calls the `cabalAddCommand`, +-- using dependency-version suggestion pairs as input. +-- +-- Returns disabled action if no cabal files given. +-- +-- Takes haskell file and cabal file paths to create a relative path +-- to the haskell file, which is used to get a `BuildTarget`. +-- +-- In current implementation the dependency is being added to the main found +-- build target, but if there will be a way to get all build targets from a file +-- it will be possible to support addition to a build target of choice. +addDependencySuggestCodeAction + :: PluginId + -> VersionedTextDocumentIdentifier -- ^ Cabal's versioned text identifier + -> [(T.Text, T.Text)] -- ^ A dependency-version suggestion pairs + -> FilePath -- ^ Path to the haskell file (source of diagnostics) + -> FilePath -- ^ Path to the cabal file (that will be edited) + -> GenericPackageDescription + -> IO [CodeAction] +addDependencySuggestCodeAction plId verTxtDocId suggestions haskellFilePath cabalFilePath gpd = do + buildTargets <- liftIO $ getBuildTargets gpd cabalFilePath haskellFilePath + case buildTargets of + -- If there are no build targets found, run `cabal-add` command with default behaviour + [] -> pure $ mkCodeAction cabalFilePath Nothing <$> suggestions + -- Otherwise provide actions for all found targets + targets -> pure $ concat [mkCodeAction cabalFilePath (Just $ buildTargetToStringRepr target) <$> + suggestions | target <- targets] + where + -- | Note the use of `pretty` function. + -- It converts the `BuildTarget` to an acceptable string representation. + -- It will be used in as the input for `cabal-add`'s `executeConfig`. + buildTargetToStringRepr target = render $ Pretty.pretty $ buildTargetComponentName target + + -- | Gives the build targets that are used in the `CabalAdd`. + -- Note the unorthodox usage of `readBuildTargets`: + -- If the relative path to the haskell file is provided, + -- the `readBuildTargets` will return a main build target. + -- This behaviour is acceptable for now, but changing to a way of getting + -- all build targets in a file is advised. + getBuildTargets :: GenericPackageDescription -> FilePath -> FilePath -> IO [BuildTarget] + getBuildTargets gpd cabalFilePath haskellFilePath = do + let haskellFileRelativePath = makeRelative (dropFileName cabalFilePath) haskellFilePath + readBuildTargets (verboseNoStderr silent) (flattenPackageDescription gpd) [haskellFileRelativePath] + + mkCodeAction :: FilePath -> Maybe String -> (T.Text, T.Text) -> CodeAction + mkCodeAction cabalFilePath target (suggestedDep, suggestedVersion) = + let + versionTitle = if T.null suggestedVersion then T.empty else " version " <> suggestedVersion + targetTitle = case target of + Nothing -> T.empty + Just t -> " target " <> T.pack t + title = "Add dependency " <> suggestedDep <> versionTitle <> targetTitle + version = if T.null suggestedVersion then Nothing else Just suggestedVersion + + params = CabalAddCommandParams {cabalPath = cabalFilePath + , verTxtDocId = verTxtDocId + , buildTarget = target + , dependency = suggestedDep + , version=version} + command = mkLspCommand plId (CommandId cabalAddCommand) "Add missing dependency" (Just [toJSON params]) + in CodeAction title (Just CodeActionKind_QuickFix) (Just []) Nothing Nothing Nothing (Just command) Nothing + +-- | Gives a mentioned number of @(dependency, version)@ pairs +-- found in the "hidden package" diagnostic message. +-- +-- For example, if a ghc error looks like this: +-- +-- > "Could not load module ‘Data.List.Split’ +-- > It is a member of the hidden package ‘split-0.2.5’. +-- > Perhaps you need to add ‘split’ to the build-depends in your .cabal file." +-- +-- It extracts mentioned package names and version numbers. +-- In this example, it will be @[("split", "0.2.5")]@ +-- +-- Also supports messages without a version. +-- +-- > "Perhaps you need to add ‘split’ to the build-depends in your .cabal file." +-- +-- Will turn into @[("split", "")]@ +hiddenPackageSuggestion :: Diagnostic -> [(T.Text, T.Text)] +hiddenPackageSuggestion diag = getMatch (msg =~ regex) + where + msg :: T.Text + msg = _message diag + regex :: T.Text -- TODO: Support multiple packages suggestion + regex = "It is a member of the hidden package [\8216']([a-zA-Z0-9-]*[a-zA-Z0-9])(-([0-9\\.]*))?[\8217']" + -- Have to do this matching because `Regex.TDFA` doesn't(?) support + -- not-capturing groups like (?:message) + getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> [(T.Text, T.Text)] + getMatch (_, _, _, []) = [] + getMatch (_, _, _, [dependency, _, cleanVersion]) = [(dependency, cleanVersion)] + getMatch (_, _, _, _) = error "Impossible pattern matching case" + +command :: Recorder (WithPriority Log) -> CommandFunction IdeState CabalAddCommandParams +command recorder state _ params@(CabalAddCommandParams {cabalPath = path, verTxtDocId = verTxtDocId, buildTarget = target, dependency = dep, version = mbVer}) = do + logWith recorder Debug $ LogCalledCabalAddCommand params + let specifiedDep = case mbVer of + Nothing -> dep + Just ver -> dep <> " ^>=" <> ver + caps <- lift pluginGetClientCapabilities + let env = (state, caps, verTxtDocId) + edit <- getDependencyEdit recorder env path target (fromList [T.unpack specifiedDep]) + void $ lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + logWith recorder Debug LogExecutedCommand + pure $ InR Null + +-- | Constructs prerequisites for the @executeConfig@ +-- and runs it, given path to the cabal file and a dependency message. +-- Given the new contents of the cabal file constructs and returns the @edit@. +-- Inspired by @main@ in cabal-add, +-- Distribution.Client.Main +getDependencyEdit :: MonadIO m => Recorder (WithPriority Log) -> (IdeState, ClientCapabilities, VersionedTextDocumentIdentifier) -> + FilePath -> Maybe String -> NonEmpty String -> ExceptT PluginError m WorkspaceEdit +getDependencyEdit recorder env cabalFilePath buildTarget dependency = do + let (state, caps, verTxtDocId) = env + (mbCnfOrigContents, mbFields, mbPackDescr) <- liftIO $ runAction "cabal.cabal-add" state $ do + contents <- useWithStale GetFileContents $ toNormalizedFilePath cabalFilePath + inFields <- useWithStale ParseCabalFields $ toNormalizedFilePath cabalFilePath + inPackDescr <- useWithStale ParseCabalFile $ toNormalizedFilePath cabalFilePath + let mbCnfOrigContents = case snd . fst <$> contents of + Just (Just txt) -> Just $ encodeUtf8 txt + _ -> Nothing + let mbFields = fst <$> inFields + let mbPackDescr = fst <$> inPackDescr + pure (mbCnfOrigContents, mbFields, mbPackDescr) + + -- Check if required info was received, + -- otherwise fall back on other options. + (cnfOrigContents, fields, packDescr) <- do + cnfOrigContents <- case mbCnfOrigContents of + (Just cnfOrigContents) -> pure cnfOrigContents + Nothing -> readCabalFile cabalFilePath + (fields, packDescr) <- case (mbFields, mbPackDescr) of + (Just fields, Just packDescr) -> pure (fields, packDescr) + (_, _) -> case parseCabalFile cabalFilePath cnfOrigContents of + Left err -> throwE $ PluginInternalError $ T.pack err + Right (f ,gpd) -> pure (f, gpd) + pure (cnfOrigContents, fields, packDescr) + + let inputs = do + let rcnfComponent = buildTarget + let specVer = specVersion $ packageDescription packDescr + cmp <- resolveComponent cabalFilePath (fields, packDescr) rcnfComponent + deps <- traverse (validateDependency specVer) dependency + pure (fields, packDescr, cmp, deps) + + (cnfFields, origPackDescr, cnfComponent, cnfDependencies) <- case inputs of + Left err -> throwE $ PluginInternalError $ T.pack err + Right pair -> pure pair + + case executeConfig (validateChanges origPackDescr) (Config {..}) of + Nothing -> throwE $ PluginInternalError $ T.pack $ "Cannot extend build-depends in " ++ cabalFilePath + Just newContents -> do + let edit = diffText caps (verTxtDocId, T.decodeUtf8 cnfOrigContents) (T.decodeUtf8 newContents) SkipDeletions + logWith recorder Debug $ LogCreatedEdit edit + pure edit + +-- | Given a path to a haskell file, returns the closest cabal file. +-- If cabal file wasn't found, gives Nothing. +findResponsibleCabalFile :: FilePath -> IO (Maybe FilePath) +findResponsibleCabalFile haskellFilePath = do + let dirPath = dropFileName haskellFilePath + allDirPaths = reverse $ scanl1 () (splitPath dirPath) -- sorted from most to least specific + go allDirPaths + where + go [] = pure Nothing + go (path:ps) = do + objects <- listDirectory path + let objectsWithPaths = map (\obj -> path <> obj) objects + objectsCabalExtension = filter (\c -> takeExtension c == ".cabal") objectsWithPaths + cabalFiles <- filterM (\c -> doesFileExist c) objectsCabalExtension + case safeHead cabalFiles of + Nothing -> go ps + Just cabalFile -> pure $ Just cabalFile + +-- | Gives cabal file's contents or throws error. +-- Inspired by @readCabalFile@ in cabal-add, +-- Distribution.Client.Main +-- +-- This is a fallback option! +-- Use only if the `GetFileContents` fails. +readCabalFile :: MonadIO m => FilePath -> ExceptT PluginError m ByteString +readCabalFile fileName = do + cabalFileExists <- liftIO $ doesFileExist fileName + if cabalFileExists + then snd . patchQuirks <$> liftIO (B.readFile fileName) + else throwE $ PluginInternalError $ T.pack ("Failed to read cabal file at " <> fileName) diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs index 84ec3ec345..b8cb7ce0d6 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs @@ -1,12 +1,33 @@ -module Ide.Plugin.Cabal.Completion.CabalFields (findStanzaForColumn, findFieldSection, getOptionalSectionName, getAnnotation, getFieldName, onelineSectionArgs) where +module Ide.Plugin.Cabal.Completion.CabalFields + ( findStanzaForColumn + , getModulesNames + , getFieldLSPRange + , findFieldSection + , findTextWord + , findFieldLine + , getOptionalSectionName + , getAnnotation + , getFieldName + , onelineSectionArgs + , getFieldEndPosition + , getSectionArgEndPosition + , getNameEndPosition + , getFieldLineEndPosition + ) + where +import qualified Data.ByteString as BS +import Data.List (find) +import Data.List.Extra (groupSort) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Data.Tuple (swap) import qualified Distribution.Fields as Syntax import qualified Distribution.Parsec.Position as Syntax import Ide.Plugin.Cabal.Completion.Types +import qualified Language.LSP.Protocol.Types as LSP -- ---------------------------------------------------------------- -- Cabal-syntax utilities I don't really want to write myself @@ -28,7 +49,7 @@ findStanzaForColumn col ctx = case NE.uncons ctx of -- -- The result is said field and its starting position -- or Nothing if the passed list of fields is empty. - +-- -- This only looks at the row of the cursor and not at the cursor's -- position within the row. -- @@ -46,6 +67,71 @@ findFieldSection cursor (x:y:ys) where cursorLine = Syntax.positionRow cursor +-- | Determine the field line the cursor is currently a part of. +-- +-- The result is said field line and its starting position +-- or Nothing if the passed list of fields is empty. +-- +-- This function assumes that elements in a field's @FieldLine@ list +-- do not share the same row. +findFieldLine :: Syntax.Position -> [Syntax.Field Syntax.Position] -> Maybe (Syntax.FieldLine Syntax.Position) +findFieldLine _cursor [] = Nothing +findFieldLine cursor fields = + case findFieldSection cursor fields of + Nothing -> Nothing + Just (Syntax.Field _ fieldLines) -> find filterLineFields fieldLines + Just (Syntax.Section _ _ fields) -> findFieldLine cursor fields + where + cursorLine = Syntax.positionRow cursor + -- In contrast to `Field` or `Section`, `FieldLine` must have the exact + -- same line position as the cursor. + filterLineFields (Syntax.FieldLine pos _) = Syntax.positionRow pos == cursorLine + +-- | Determine the exact word at the current cursor position. +-- +-- The result is said word or Nothing if the passed list is empty +-- or the cursor position is not next to, or on a word. +-- For this function, a word is a sequence of consecutive characters +-- that are not a space or column. +-- +-- This function currently only considers words inside of a @FieldLine@. +findTextWord :: Syntax.Position -> [Syntax.Field Syntax.Position] -> Maybe T.Text +findTextWord _cursor [] = Nothing +findTextWord cursor fields = + case findFieldLine cursor fields of + Nothing -> Nothing + Just (Syntax.FieldLine pos byteString) -> + let decodedText = T.decodeUtf8 byteString + lineFieldCol = Syntax.positionCol pos + lineFieldLen = T.length decodedText + offset = cursorCol - lineFieldCol in + -- Range check if cursor is inside or or next to found line. + -- The latter comparison includes the length of the line as offset, + -- which is done to also include cursors that are at the end of a line. + -- e.g. "foo,bar|" + -- ^ + -- cursor + -- + -- Having an offset which is outside of the line is possible because of `splitAt`. + if offset >= 0 && lineFieldLen >= offset + then + let (lhs, rhs) = T.splitAt offset decodedText + strippedLhs = T.takeWhileEnd isAllowedChar lhs + strippedRhs = T.takeWhile isAllowedChar rhs + resultText = T.concat [strippedLhs, strippedRhs] in + -- It could be possible that the cursor was in-between separators, in this + -- case the resulting text would be empty, which should result in `Nothing`. + -- e.g. " foo ,| bar" + -- ^ + -- cursor + if not $ T.null resultText then Just resultText else Nothing + else + Nothing + where + cursorCol = Syntax.positionCol cursor + separators = [',', ' '] + isAllowedChar = (`notElem` separators) + type FieldName = T.Text getAnnotation :: Syntax.Field ann -> ann @@ -56,6 +142,9 @@ getFieldName :: Syntax.Field ann -> FieldName getFieldName (Syntax.Field (Syntax.Name _ fn) _) = T.decodeUtf8 fn getFieldName (Syntax.Section (Syntax.Name _ fn) _ _) = T.decodeUtf8 fn +getFieldLineName :: Syntax.FieldLine ann -> FieldName +getFieldLineName (Syntax.FieldLine _ fn) = T.decodeUtf8 fn + -- | Returns the name of a section if it has a name. -- -- This assumes that the given section args belong to named stanza @@ -66,6 +155,107 @@ getOptionalSectionName (x:xs) = case x of Syntax.SecArgName _ name -> Just (T.decodeUtf8 name) _ -> getOptionalSectionName xs +type BuildTargetName = T.Text +type ModuleName = T.Text + +-- | Given a cabal AST returns pairs of all respective target names +-- and the module name bound to them. If a target is a main library gives +-- @Nothing@, otherwise @Just target-name@ +-- +-- Examples of input cabal files and the outputs: +-- +-- * Target is a main library module: +-- +-- > library +-- > exposed-modules: +-- > MyLib +-- +-- * @getModulesNames@ output: +-- +-- > [([Nothing], "MyLib")] +-- +-- * Same module names in different targets: +-- +-- > test-suite first-target +-- > other-modules: +-- > Config +-- > test-suite second-target +-- > other-modules: +-- > Config +-- +-- * @getModulesNames@ output: +-- +-- > [([Just "first-target", Just "second-target"], "Config")] +getModulesNames :: [Syntax.Field any] -> [([Maybe BuildTargetName], ModuleName)] +getModulesNames fields = map swap $ groupSort rawModuleTargetPairs + where + rawModuleTargetPairs = concatMap getSectionModuleNames sections + sections = getSectionsWithModules fields + + getSectionModuleNames :: Syntax.Field any -> [(ModuleName, Maybe BuildTargetName)] + getSectionModuleNames (Syntax.Section _ secArgs fields) = map (, getArgsName secArgs) $ concatMap getFieldModuleNames fields + getSectionModuleNames _ = [] + + getArgsName [Syntax.SecArgName _ name] = Just $ T.decodeUtf8 name + getArgsName _ = Nothing -- Can be only a main library, that has no name + -- since it's impossible to have multiple names for a build target + + getFieldModuleNames field@(Syntax.Field _ modules) = if getFieldName field == T.pack "exposed-modules" || + getFieldName field == T.pack "other-modules" + then map getFieldLineName modules + else [] + getFieldModuleNames _ = [] + +-- | Trims a given cabal AST leaving only targets and their +-- @exposed-modules@ and @other-modules@ sections. +-- +-- For example: +-- +-- * Given a cabal file like this: +-- +-- > library +-- > import: extra +-- > hs-source-dirs: source/directory +-- > ... +-- > exposed-modules: +-- > Important.Exposed.Module +-- > other-modules: +-- > Important.Other.Module +-- > +-- > test-suite tests +-- > type: type +-- > build-tool-depends: tool +-- > other-modules: +-- > Important.Other.Module +-- +-- * @getSectionsWithModules@ gives output: +-- +-- > library +-- > exposed-modules: +-- > Important.Exposed.Module +-- > other-modules: +-- > Important.Other.Module +-- > test-suite tests +-- > other-modules: +-- > Important.Other.Module +getSectionsWithModules :: [Syntax.Field any] -> [Syntax.Field any] +getSectionsWithModules fields = concatMap go fields + where + go :: Syntax.Field any -> [Syntax.Field any] + go (Syntax.Field _ _) = [] + go section@(Syntax.Section _ _ fields) = concatMap onlySectionsWithModules (section:fields) + + onlySectionsWithModules :: Syntax.Field any -> [Syntax.Field any] + onlySectionsWithModules (Syntax.Field _ _) = [] + onlySectionsWithModules (Syntax.Section name secArgs fields) + | (not . null) newFields = [Syntax.Section name secArgs newFields] + | otherwise = [] + where newFields = filter subfieldHasModule fields + + subfieldHasModule :: Syntax.Field any -> Bool + subfieldHasModule field@(Syntax.Field _ _) = getFieldName field == T.pack "exposed-modules" || + getFieldName field == T.pack "other-modules" + subfieldHasModule (Syntax.Section _ _ _) = False -- | Makes a single text line out of multiple -- @SectionArg@s. Allows to display conditions, @@ -73,12 +263,41 @@ getOptionalSectionName (x:xs) = case x of -- -- For example, @flag@ @(@ @pedantic@ @)@ will be joined in -- one line, instead of four @SectionArg@s separately. -onelineSectionArgs :: [Syntax.SectionArg Syntax.Position] -> T.Text +onelineSectionArgs :: [Syntax.SectionArg ann] -> T.Text onelineSectionArgs sectionArgs = joinedName where joinedName = T.unwords $ map getName sectionArgs - getName :: Syntax.SectionArg Syntax.Position -> T.Text + getName :: Syntax.SectionArg ann -> T.Text getName (Syntax.SecArgName _ identifier) = T.decodeUtf8 identifier getName (Syntax.SecArgStr _ quotedString) = T.decodeUtf8 quotedString getName (Syntax.SecArgOther _ string) = T.decodeUtf8 string + +-- | Returns the end position of a provided field +getFieldEndPosition :: Syntax.Field Syntax.Position -> Syntax.Position +getFieldEndPosition (Syntax.Field name []) = getNameEndPosition name +getFieldEndPosition (Syntax.Field _ (x:xs)) = getFieldLineEndPosition $ NE.last (x NE.:| xs) +getFieldEndPosition (Syntax.Section name [] []) = getNameEndPosition name +getFieldEndPosition (Syntax.Section _ (x:xs) []) = getSectionArgEndPosition $ NE.last (x NE.:| xs) +getFieldEndPosition (Syntax.Section _ _ (x:xs)) = getFieldEndPosition $ NE.last (x NE.:| xs) + +-- | Returns the end position of a provided section arg +getSectionArgEndPosition :: Syntax.SectionArg Syntax.Position -> Syntax.Position +getSectionArgEndPosition (Syntax.SecArgName (Syntax.Position row col) byteString) = Syntax.Position row (col + BS.length byteString) +getSectionArgEndPosition (Syntax.SecArgStr (Syntax.Position row col) byteString) = Syntax.Position row (col + BS.length byteString) +getSectionArgEndPosition (Syntax.SecArgOther (Syntax.Position row col) byteString) = Syntax.Position row (col + BS.length byteString) + +-- | Returns the end position of a provided name +getNameEndPosition :: Syntax.Name Syntax.Position -> Syntax.Position +getNameEndPosition (Syntax.Name (Syntax.Position row col) byteString) = Syntax.Position row (col + BS.length byteString) + +-- | Returns the end position of a provided field line +getFieldLineEndPosition :: Syntax.FieldLine Syntax.Position -> Syntax.Position +getFieldLineEndPosition (Syntax.FieldLine (Syntax.Position row col) byteString) = Syntax.Position row (col + BS.length byteString) + +-- | Returns an LSP compatible range for a provided field +getFieldLSPRange :: Syntax.Field Syntax.Position -> LSP.Range +getFieldLSPRange field = LSP.Range startLSPPos endLSPPos + where + startLSPPos = cabalPositionToLSPPosition $ getAnnotation field + endLSPPos = cabalPositionToLSPPosition $ getFieldEndPosition field diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs new file mode 100644 index 0000000000..5f85151199 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.Cabal.Definition where + +import Control.Lens ((^.)) +import Control.Monad.Extra +import Control.Monad.IO.Class +import Data.List (find) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import Development.IDE as D +import Development.IDE.Core.PluginUtils +import qualified Distribution.Fields as Syntax +import Distribution.PackageDescription (Benchmark (..), + BuildInfo (..), + Executable (..), + ForeignLib (..), + GenericPackageDescription, + Library (..), + LibraryName (LMainLibName, LSubLibName), + PackageDescription (..), + TestSuite (..), + library, + unUnqualComponentName) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import qualified Distribution.Parsec.Position as Syntax +import Distribution.Utils.Generic (safeHead) +import Distribution.Utils.Path (getSymbolicPath) +import Ide.Plugin.Cabal.Completion.CabalFields as CabalFields +import Ide.Plugin.Cabal.Completion.Types (ParseCabalCommonSections (ParseCabalCommonSections), + ParseCabalFields (..), + ParseCabalFile (..)) +import qualified Ide.Plugin.Cabal.Completion.Types as Types +import Ide.Plugin.Cabal.Orphans () +import Ide.Plugin.Error +import Ide.Types +import qualified Language.LSP.Protocol.Lens as JL +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types +import System.Directory (doesFileExist) +import System.FilePath (joinPath, + takeDirectory, + (<.>), ()) + +-- | Handler for going to definitions. +-- +-- Provides a handler for going to the definition in a cabal file, +-- gathering all possible definitions by calling subfunctions. + +-- TODO: Resolve more cases for go-to definition. +gotoDefinition :: PluginMethodHandler IdeState LSP.Method_TextDocumentDefinition +gotoDefinition ide _ msgParam = do + nfp <- getNormalizedFilePathE uri + cabalFields <- runActionE "cabal-plugin.commonSections" ide $ useE ParseCabalFields nfp + -- Trim the AST tree, so multiple passes in subfunctions won't hurt the performance. + let fieldsOfInterest = maybe cabalFields (:[] ) $ CabalFields.findFieldSection cursor cabalFields + + commonSections <- runActionE "cabal-plugin.commonSections" ide $ useE ParseCabalCommonSections nfp + let mCommonSectionsDef = gotoCommonSectionDefinition uri commonSections cursor fieldsOfInterest + + mModuleDef <- do + mGPD <- liftIO $ runAction "cabal.GPD" ide $ useWithStale ParseCabalFile nfp + case mGPD of + Nothing -> pure Nothing + Just (gpd, _) -> liftIO $ gotoModulesDefinition nfp gpd cursor fieldsOfInterest + + let defs = Maybe.catMaybes [ mCommonSectionsDef + , mModuleDef + ] + -- Take first found definition. + -- We assume, that there can't be multiple definitions, + -- or the most specific definitions come first. + case safeHead defs of + Nothing -> pure $ InR $ InR Null + Just def -> pure $ InL def + where + cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position) + uri = msgParam ^. JL.textDocument . JL.uri + +-- | Definitions for Sections. +-- +-- Provides a Definition if cursor is pointed at an identifier, +-- otherwise gives Nothing. +-- The definition is found by traversing the sections and comparing their name to +-- the clicked identifier. +gotoCommonSectionDefinition + :: Uri -- ^ Cabal file URI + -> [Syntax.Field Syntax.Position] -- ^ Found common sections + -> Syntax.Position -- ^ Cursor position + -> [Syntax.Field Syntax.Position] -- ^ Trimmed cabal AST on a cursor + -> Maybe Definition +gotoCommonSectionDefinition uri commonSections cursor fieldsOfInterest = do + cursorText <- CabalFields.findTextWord cursor fieldsOfInterest + commonSection <- find (isSectionArgName cursorText) commonSections + Just $ Definition $ InL $ Location uri $ CabalFields.getFieldLSPRange commonSection + where + isSectionArgName name (Syntax.Section _ sectionArgName _) = name == CabalFields.onelineSectionArgs sectionArgName + isSectionArgName _ _ = False + +-- | Definitions for Modules. +-- +-- Provides a Definition if cursor is pointed at a +-- exposed-module or other-module field, otherwise gives Nothing +-- +-- Definition is found by looking for a module name, +-- the cursor is pointing to and looking for it in @BuildInfo@s. +-- Note that since a trimmed ast is provided, a @Definition@ to +-- a module with the same name as the target one, +-- but in another build target can't be given. +-- +-- See resolving @Config@ module in tests. +gotoModulesDefinition + :: NormalizedFilePath -- ^ Normalized FilePath to the cabal file + -> GenericPackageDescription + -> Syntax.Position -- ^ Cursor position + -> [Syntax.Field Syntax.Position] -- ^ Trimmed cabal AST on a cursor + -> IO (Maybe Definition) +gotoModulesDefinition nfp gpd cursor fieldsOfInterest = do + let mCursorText = CabalFields.findTextWord cursor fieldsOfInterest + moduleNames = CabalFields.getModulesNames fieldsOfInterest + mModuleName = find (isModuleName mCursorText) moduleNames + + case mModuleName of + Nothing -> pure Nothing + Just (mBuildTargetNames, moduleName) -> do + let buildInfos = foldMap (lookupBuildTargetPackageDescription + (flattenPackageDescription gpd)) + mBuildTargetNames + sourceDirs = map getSymbolicPath $ concatMap hsSourceDirs buildInfos + potentialPaths = map (\dir -> takeDirectory (fromNormalizedFilePath nfp) dir toHaskellFile moduleName) sourceDirs + allPaths <- liftIO $ filterM doesFileExist potentialPaths + -- Don't provide the range, since there is little benefit for it + let locations = map (\pth -> Location (filePathToUri pth) (mkRange 0 0 0 0)) allPaths + case safeHead locations of -- We assume there could be only one source location + Nothing -> pure Nothing + Just location -> pure $ Just $ Definition $ InL location + where + isModuleName (Just name) (_, moduleName) = name == moduleName + isModuleName _ _ = False + +-- | Gives all `buildInfo`s given a target name. +-- +-- `Maybe buildTargetName` is provided, and if it's +-- Nothing we assume, that it's a main library. +-- Otherwise looks for the provided name. +lookupBuildTargetPackageDescription :: PackageDescription -> Maybe T.Text -> [BuildInfo] +lookupBuildTargetPackageDescription (PackageDescription {..}) Nothing = + case library of + Nothing -> [] -- Target is a main library but no main library was found + Just (Library {libBuildInfo}) -> [libBuildInfo] +lookupBuildTargetPackageDescription (PackageDescription {..}) (Just buildTargetName) = + Maybe.catMaybes $ + map executableNameLookup executables <> + map subLibraryNameLookup subLibraries <> + map foreignLibsNameLookup foreignLibs <> + map testSuiteNameLookup testSuites <> + map benchmarkNameLookup benchmarks + where + executableNameLookup :: Executable -> Maybe BuildInfo + executableNameLookup (Executable {exeName, buildInfo}) = + if T.pack (unUnqualComponentName exeName) == buildTargetName + then Just buildInfo + else Nothing + subLibraryNameLookup :: Library -> Maybe BuildInfo + subLibraryNameLookup (Library {libName, libBuildInfo}) = + case libName of + (LSubLibName name) -> + if T.pack (unUnqualComponentName name) == buildTargetName + then Just libBuildInfo + else Nothing + LMainLibName -> Nothing + foreignLibsNameLookup :: ForeignLib -> Maybe BuildInfo + foreignLibsNameLookup (ForeignLib {foreignLibName, foreignLibBuildInfo}) = + if T.pack (unUnqualComponentName foreignLibName) == buildTargetName + then Just foreignLibBuildInfo + else Nothing + testSuiteNameLookup :: TestSuite -> Maybe BuildInfo + testSuiteNameLookup (TestSuite {testName, testBuildInfo}) = + if T.pack (unUnqualComponentName testName) == buildTargetName + then Just testBuildInfo + else Nothing + benchmarkNameLookup :: Benchmark -> Maybe BuildInfo + benchmarkNameLookup (Benchmark {benchmarkName, benchmarkBuildInfo}) = + if T.pack (unUnqualComponentName benchmarkName) == buildTargetName + then Just benchmarkBuildInfo + else Nothing + +-- | Converts a name of a module to a FilePath. +-- Is needed to guess the relative path to a file +-- using the name of the module. +-- We assume, that correct module naming is guaranteed. +-- +-- Warning: Generally not advised to use, if there are +-- better ways to get the path. +-- +-- Examples: (output is system dependent) +-- >>> toHaskellFile "My.Module.Lib" +-- "My/Module/Lib.hs" +-- >>> toHaskellFile "Main" +-- "Main.hs" +toHaskellFile :: T.Text -> FilePath +toHaskellFile moduleName = joinPath (map T.unpack $ T.splitOn "." moduleName) <.> ".hs" diff --git a/plugins/hls-cabal-plugin/test/CabalAdd.hs b/plugins/hls-cabal-plugin/test/CabalAdd.hs new file mode 100644 index 0000000000..f6bc7dbde0 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/CabalAdd.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} + +module CabalAdd ( + cabalAddTests, +) where + +import Control.Lens ((^.)) +import Control.Lens.Fold ((^?)) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import qualified Data.Text.Internal.Search as T +import Distribution.Utils.Generic (safeHead) +import Ide.Plugin.Cabal.CabalAdd (hiddenPackageSuggestion) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types (Diagnostic (..), mkRange) +import System.FilePath +import Test.Hls (Session, TestTree, _R, anyMessage, + assertEqual, documentContents, + executeCodeAction, + expectFailBecause, + getAllCodeActions, + getDocumentEdit, liftIO, openDoc, + skipManyTill, testCase, testGroup, + waitForDiagnosticsFrom, (@?=)) +import Utils + +cabalAddTests :: TestTree +cabalAddTests = + testGroup + "CabalAdd Tests" + [ runHaskellTestCaseSession "Code Actions - Can add hidden package" ("cabal-add-testdata" "cabal-add-exe") + (generateAddDependencyTestSession "cabal-add-exe.cabal" ("src" "Main.hs") "split" [253]) + , runHaskellTestCaseSession "Code Actions - Can add hidden package to a library" ("cabal-add-testdata" "cabal-add-lib") + (generateAddDependencyTestSession "cabal-add-lib.cabal" ("src" "MyLib.hs") "split" [348]) + , runHaskellTestCaseSession "Code Actions - Can add hidden package to a test" ("cabal-add-testdata" "cabal-add-tests") + (generateAddDependencyTestSession "cabal-add-tests.cabal" ("test" "Main.hs") "split" [478]) + , runHaskellTestCaseSession "Code Actions - Can add hidden package to a benchmark" ("cabal-add-testdata" "cabal-add-bench") + (generateAddDependencyTestSession "cabal-add-bench.cabal" ("bench" "Main.hs") "split" [403]) + , testHiddenPackageSuggestions "Check CabalAdd's parser, no version" + [ "It is a member of the hidden package 'base'" + , "It is a member of the hidden package 'Blammo-wai'" + , "It is a member of the hidden package 'BlastHTTP'" + , "It is a member of the hidden package 'CC-delcont-ref-tf'" + , "It is a member of the hidden package '3d-graphics-examples'" + , "It is a member of the hidden package 'AAI'" + , "It is a member of the hidden package 'AWin32Console'" + ] + [ ("base", T.empty) + , ("Blammo-wai", T.empty) + , ("BlastHTTP", T.empty) + , ("CC-delcont-ref-tf", T.empty) + , ("3d-graphics-examples", T.empty) + , ("AAI", T.empty) + , ("AWin32Console", T.empty) + ] + , testHiddenPackageSuggestions "Check CabalAdd's parser, with version" + [ "It is a member of the hidden package 'base-0.1.0.0'" + , "It is a member of the hidden package 'Blammo-wai-0.11.0'" + , "It is a member of the hidden package 'BlastHTTP-2.6.4.3'" + , "It is a member of the hidden package 'CC-delcont-ref-tf-0.0.0.2'" + , "It is a member of the hidden package '3d-graphics-examples-1.1.6'" + , "It is a member of the hidden package 'AAI-0.1'" + , "It is a member of the hidden package 'AWin32Console-1.19.1'" + ] + [ ("base","0.1.0.0") + , ("Blammo-wai", "0.11.0") + , ("BlastHTTP", "2.6.4.3") + , ("CC-delcont-ref-tf", "0.0.0.2") + , ("3d-graphics-examples", "1.1.6") + , ("AAI", "0.1") + , ("AWin32Console", "1.19.1") + ] + , testHiddenPackageSuggestions "Check CabalAdd's parser, no version, unicode comma" + [ "It is a member of the hidden package \8216base\8217" + , "It is a member of the hidden package \8216Blammo-wai\8217" + , "It is a member of the hidden package \8216BlastHTTP\8217" + , "It is a member of the hidden package \8216CC-delcont-ref-tf\8217" + , "It is a member of the hidden package \8216AAI\8217" + , "It is a member of the hidden package \8216AWin32Console\8217" + ] + [ ("base", T.empty) + , ("Blammo-wai", T.empty) + , ("BlastHTTP", T.empty) + , ("CC-delcont-ref-tf", T.empty) + , ("AAI", T.empty) + , ("AWin32Console", T.empty) + ] + , testHiddenPackageSuggestions "Check CabalAdd's parser, with version, unicode comma" + [ "It is a member of the hidden package \8216base-0.1.0.0\8217" + , "It is a member of the hidden package \8216Blammo-wai-0.11.0\8217" + , "It is a member of the hidden package \8216BlastHTTP-2.6.4.3\8217" + , "It is a member of the hidden package \8216CC-delcont-ref-tf-0.0.0.2\8217" + , "It is a member of the hidden package \8216AAI-0.1\8217" + , "It is a member of the hidden package \8216AWin32Console-1.19.1\8217" + ] + [ ("base","0.1.0.0") + , ("Blammo-wai", "0.11.0") + , ("BlastHTTP", "2.6.4.3") + , ("CC-delcont-ref-tf", "0.0.0.2") + , ("AAI", "0.1") + , ("AWin32Console", "1.19.1") + ] + , expectFailBecause "TODO fix regex for these cases" $ + testHiddenPackageSuggestions "Check CabalAdd's parser, with version, unicode comma" + [ "It is a member of the hidden package \82163d-graphics-examples\8217" + , "It is a member of the hidden package \82163d-graphics-examples-1.1.6\8217" + ] + [ ("3d-graphics-examples", T.empty) + , ("3d-graphics-examples", "1.1.6") + ] + ] + where + generateAddDependencyTestSession :: FilePath -> FilePath -> T.Text -> [Int] -> Session () + generateAddDependencyTestSession cabalFile haskellFile dependency indicesRes = do + hsdoc <- openDoc haskellFile "haskell" + cabDoc <- openDoc cabalFile "cabal" + _ <- waitForDiagnosticsFrom hsdoc + cas <- Maybe.mapMaybe (^? _R) <$> getAllCodeActions hsdoc + let selectedCas = filter (\ca -> "Add dependency" `T.isPrefixOf` (ca ^. L.title)) cas + mapM_ executeCodeAction selectedCas + _ <- skipManyTill anyMessage $ getDocumentEdit cabDoc -- Wait for the changes in cabal file + contents <- documentContents cabDoc + liftIO $ assertEqual (T.unpack dependency <> " isn't found in the cabal file") indicesRes (T.indices dependency contents) + testHiddenPackageSuggestions :: String -> [T.Text] -> [(T.Text, T.Text)] -> TestTree + testHiddenPackageSuggestions testTitle messages suggestions = + let diags = map (\msg -> messageToDiagnostic msg ) messages + suggestions' = map (safeHead . hiddenPackageSuggestion) diags + assertions = zipWith (@?=) suggestions' (map Just suggestions) + testNames = map (\(f, s) -> "Check if " ++ T.unpack f ++ (if s == "" then "" else "-") ++ T.unpack s ++ " was parsed correctly") suggestions + test = testGroup testTitle $ zipWith testCase testNames assertions + in test + messageToDiagnostic :: T.Text -> Diagnostic + messageToDiagnostic msg = Diagnostic { + _range = mkRange 0 0 0 0 + , _severity = Nothing + , _code = Nothing + , _source = Nothing + , _message = msg + , _relatedInformation = Nothing + , _tags = Nothing + , _codeDescription = Nothing + , _data_ = Nothing + } diff --git a/plugins/hls-cabal-plugin/test/Definition.hs b/plugins/hls-cabal-plugin/test/Definition.hs new file mode 100644 index 0000000000..33163c03eb --- /dev/null +++ b/plugins/hls-cabal-plugin/test/Definition.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Definition ( + gotoDefinitionTests, +) where + +import Control.Lens ((^.)) +import Data.List.Extra (isSuffixOf) +import qualified Data.Text as T +import Ide.Plugin.Cabal.Definition (toHaskellFile) +import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Types as LSP +import System.FilePath +import Test.Hls +import Utils + + +gotoDefinitionTests :: TestTree +gotoDefinitionTests = testGroup "Goto Definition" + [ gotoCommonSectionDefinitionTests + , gotoModuleDefinitionTests + ] + +gotoModuleDefinitionTests :: TestTree +gotoModuleDefinitionTests = testGroup "Goto Module Definition" + [ testGoToDefinitionLink "simple cabal test" "simple-cabal" "simple-cabal.cabal" + (Position 8 23) (toTestHaskellPath "" "A") + + , testGoToDefinitionLink "library start of exposed-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 6 22) (toTestHaskellPath "src" "Library.Lib") + , testGoToDefinitionLink "library middle of exposed-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 6 29) (toTestHaskellPath "src" "Library.Lib") + , testGoToDefinitionLink "library end of exposed-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 6 33) (toTestHaskellPath "src" "Library.Lib") + , testGoToDefinitionLink "library start of other-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 9 22) (toTestHaskellPath "src" "Library.Other.OtherLib") + , testGoToDefinitionLink "library end of other-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 9 44) (toTestHaskellPath "src" "Library.Other.OtherLib") + + , testGoToDefinitionLink "executable other-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 22 10) (toTestHaskellPath ("src" "exe") "Config") + + , testGoToDefinitionLink "test-suite other-modules Config" ("goto-definition" "modules") "module-examples.cabal" + (Position 31 10) (toTestHaskellPath ("src" "test") "Config") + , testGoToDefinitionLink "test-suite other-modules Library" ("goto-definition" "modules") "module-examples.cabal" + (Position 34 10) (toTestHaskellPath ("src" "test") "Library") + + , testGoToDefinitionLink "benchmark other-modules Config" ("goto-definition" "modules") "module-examples.cabal" + (Position 45 30) (toTestHaskellPath ("src" "bench") "Config") + + , testGoToDefinitionLinkNoLocation "not existent module" ("goto-definition" "modules") "module-examples.cabal" (Position 48 25) + , testGoToDefinitionLinkNoLocation "behind module" ("goto-definition" "modules") "module-examples.cabal" (Position 9 20) + , testGoToDefinitionLinkNoLocation "after module" ("goto-definition" "modules") "module-examples.cabal" (Position 9 50) + ] + where + toTestHaskellPath :: FilePath -> T.Text -> FilePath + toTestHaskellPath dir moduleName = dir toHaskellFile moduleName + + getUriFromDefinition :: Show b => (Definition |? b) -> Uri + getUriFromDefinition (InL (Definition (InL loc))) = loc^.L.uri + getUriFromDefinition unk = error $ "Unexpected pattern '" ++ show unk ++ "' , expected '(InL (Definition (InL loc))'" + + testGoToDefinitionLink :: TestName -> FilePath -> FilePath -> Position -> FilePath -> TestTree + testGoToDefinitionLink testName testDir cabalFile cursorPos expectedFilePath = + runCabalTestCaseSession testName testDir $ do + doc <- openDoc cabalFile "cabal" + definitions <- getDefinitions doc cursorPos + let uri = getUriFromDefinition definitions + mFilePath = (testDir ) <$> uriToFilePath uri + case mFilePath of + Nothing -> error $ "Not possible to convert Uri " <> show uri <> " to FilePath" + Just filePath -> do + let filePathWithDir = testDir expectedFilePath + isCorrectPath = filePathWithDir `isSuffixOf` filePath + liftIO $ isCorrectPath @? ("Absolute path expected to end on " <> filePathWithDir <> + " but " <> filePath <> " was given.") + + testGoToDefinitionLinkNoLocation :: TestName -> FilePath -> FilePath -> Position -> TestTree + testGoToDefinitionLinkNoLocation testName testDir cabalFile cursorPos = + runCabalTestCaseSession testName testDir $ do + doc <- openDoc cabalFile "cabal" + empty <- getDefinitions doc cursorPos + liftIO $ empty @?= (InR $ InR LSP.Null) + +gotoCommonSectionDefinitionTests :: TestTree +gotoCommonSectionDefinitionTests = testGroup "Goto Common Section Definition" + [ positiveTest "middle of identifier" (Position 27 16) (mkRange 6 0 7 22) + , positiveTest "left of identifier" (Position 30 12) (mkRange 10 0 17 40) + , positiveTest "right of identifier" (Position 33 22) (mkRange 20 0 23 34) + , positiveTest "left of '-' in identifier" (Position 36 20) (mkRange 6 0 7 22) + , positiveTest "right of '-' in identifier" (Position 39 19) (mkRange 10 0 17 40) + , positiveTest "identifier in identifier list" (Position 42 16) (mkRange 20 0 23 34) + , positiveTest "left of ',' right of identifier" (Position 45 33) (mkRange 10 0 17 40) + , positiveTest "right of ',' left of identifier" (Position 48 34) (mkRange 6 0 7 22) + + , negativeTest "right of ',' left of space" (Position 51 23) + , negativeTest "right of ':' left of space" (Position 54 11) + , negativeTest "not a definition" (Position 57 8) + , negativeTest "empty space" (Position 59 7) + ] + where + getRangeFromDefinition :: Show b => (Definition |? b) -> Range + getRangeFromDefinition (InL (Definition (InL loc))) = loc^.L.range + getRangeFromDefinition unk = error $ "Unexpected pattern '" ++ show unk ++ "' , expected '(InL (Definition (InL loc))'" + + -- A positive test checks if the provided range is equal + -- to the expected range from the definition in the test file. + -- The test emulates a goto-definition request of an actual definition. + positiveTest :: TestName -> Position -> Range -> TestTree + positiveTest testName cursorPos expectedRange = + runCabalTestCaseSession testName ("goto-definition" "common-section") $ do + doc <- openDoc "simple-with-common.cabal" "cabal" + definitions <- getDefinitions doc cursorPos + let range = getRangeFromDefinition definitions + liftIO $ range @?= expectedRange + + -- A negative test checks if the request failed and + -- the provided result is empty, i.e. `InR $ InR Null`. + -- The test emulates a goto-definition request of anything but an + -- actual definition. + negativeTest :: TestName -> Position -> TestTree + negativeTest testName cursorPos = + runCabalTestCaseSession testName ("goto-definition" "common-section") $ do + doc <- openDoc "simple-with-common.cabal" "cabal" + empty <- getDefinitions doc cursorPos + liftIO $ empty @?= (InR $ InR LSP.Null) diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index ddc197c4ae..98017fa9c1 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -6,6 +6,7 @@ module Main ( main, ) where +import CabalAdd (cabalAddTests) import Completer (completerTests) import Context (contextTests) import Control.Lens ((^.)) @@ -16,7 +17,7 @@ import Data.Either (isRight) import Data.List.Extra (nubOrdOn) import qualified Data.Maybe as Maybe import qualified Data.Text as T -import qualified Data.Text as Text +import Definition (gotoDefinitionTests) import Ide.Plugin.Cabal.LicenseSuggest (licenseErrorSuggestion) import qualified Ide.Plugin.Cabal.Parse as Lib import qualified Language.LSP.Protocol.Lens as L @@ -36,6 +37,7 @@ main = do , contextTests , outlineTests , codeActionTests + , gotoDefinitionTests ] -- ------------------------------------------------------------------------ @@ -164,7 +166,7 @@ codeActionTests = testGroup "Code Actions" contents <- documentContents doc liftIO $ contents - @?= Text.unlines + @?= T.unlines [ "cabal-version: 3.0" , "name: licenseCodeAction" , "version: 0.1.0.0" @@ -188,7 +190,7 @@ codeActionTests = testGroup "Code Actions" contents <- documentContents doc liftIO $ contents - @?= Text.unlines + @?= T.unlines [ "cabal-version: 3.0" , "name: licenseCodeAction2" , "version: 0.1.0.0" @@ -220,6 +222,7 @@ codeActionTests = testGroup "Code Actions" ]) cas mapM_ executeCodeAction selectedCas pure () + , cabalAddTests ] where getLicenseAction :: T.Text -> [Command |? CodeAction] -> [CodeAction] diff --git a/plugins/hls-cabal-plugin/test/Utils.hs b/plugins/hls-cabal-plugin/test/Utils.hs index bcafa01fac..2733f94fd0 100644 --- a/plugins/hls-cabal-plugin/test/Utils.hs +++ b/plugins/hls-cabal-plugin/test/Utils.hs @@ -8,15 +8,20 @@ import Control.Monad (guard) import Data.List (sort) import Data.Proxy (Proxy (Proxy)) import qualified Data.Text as T -import Ide.Plugin.Cabal (descriptor) +import Ide.Plugin.Cabal (descriptor, + haskellInteractionDescriptor) import qualified Ide.Plugin.Cabal import Ide.Plugin.Cabal.Completion.Types import System.FilePath import Test.Hls + cabalPlugin :: PluginTestDescriptor Ide.Plugin.Cabal.Log cabalPlugin = mkPluginTestDescriptor descriptor "cabal" +cabalHaskellPlugin :: PluginTestDescriptor Ide.Plugin.Cabal.Log +cabalHaskellPlugin = mkPluginTestDescriptor haskellInteractionDescriptor "cabal-haskell" + simpleCabalPrefixInfoFromPos :: Position -> T.Text -> CabalPrefixInfo simpleCabalPrefixInfoFromPos pos prefix = CabalPrefixInfo @@ -45,10 +50,17 @@ filePathComplTestDir = addTrailingPathSeparator $ testDataDir "filepath-comp runCabalTestCaseSession :: TestName -> FilePath -> Session () -> TestTree runCabalTestCaseSession title subdir = testCase title . runCabalSession subdir +runHaskellTestCaseSession :: TestName -> FilePath -> Session () -> TestTree +runHaskellTestCaseSession title subdir = testCase title . runHaskellAndCabalSession subdir + runCabalSession :: FilePath -> Session a -> IO a runCabalSession subdir = failIfSessionTimeout . runSessionWithServer def cabalPlugin (testDataDir subdir) +runHaskellAndCabalSession :: FilePath -> Session a -> IO a +runHaskellAndCabalSession subdir = + failIfSessionTimeout . runSessionWithServer def (cabalPlugin <> cabalHaskellPlugin) (testDataDir subdir) + runCabalGoldenSession :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree runCabalGoldenSession title subdir fp act = goldenWithCabalDoc def cabalPlugin title testDataDir (subdir fp) "golden" "cabal" act diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-bench/bench/Main.hs b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-bench/bench/Main.hs new file mode 100644 index 0000000000..e5c42398f2 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-bench/bench/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Data.List.Split + +main :: IO () +main = putStrLn "Test suite not yet implemented." diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-bench/cabal-add-bench.cabal b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-bench/cabal-add-bench.cabal new file mode 100644 index 0000000000..b58a6d3302 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-bench/cabal-add-bench.cabal @@ -0,0 +1,17 @@ +cabal-version: 2.4 +name: cabal-add-bench +version: 0.1.0.0 +license: NONE +author: George Gerasev +maintainer: george30032002@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +benchmark benchmark + type: exitcode-stdio-1.0 + ghc-options: -threaded + main-is: Main.hs + hs-source-dirs: bench + build-depends: base diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-exe/cabal-add-exe.cabal b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-exe/cabal-add-exe.cabal new file mode 100644 index 0000000000..a3499bbf97 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-exe/cabal-add-exe.cabal @@ -0,0 +1,15 @@ +cabal-version: 2.4 +name: cabal-add-exe +version: 0.1.0.0 +build-type: Simple + +executable cabal-add-exe + main-is: Main.hs + hs-source-dirs: src + ghc-options: -Wall + build-depends: base + default-language: Haskell2010 + +library + build-depends: base >= 4 && < 5 + ghc-options: -Wall diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-exe/src/Main.hs b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-exe/src/Main.hs new file mode 100644 index 0000000000..0bf3e99dae --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-exe/src/Main.hs @@ -0,0 +1,5 @@ +module Main where + +import Data.List.Split + +main = putStrLn "Hello, Haskell!" \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-lib/cabal-add-lib.cabal b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-lib/cabal-add-lib.cabal new file mode 100644 index 0000000000..b00b45bb6b --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-lib/cabal-add-lib.cabal @@ -0,0 +1,17 @@ +cabal-version: 2.4 +name: cabal-add-lib +version: 0.1.0.0 +license: NONE +author: George Gerasev +maintainer: george30032002@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: MyLib + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-lib/src/MyLib.hs b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-lib/src/MyLib.hs new file mode 100644 index 0000000000..bbb506d001 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-lib/src/MyLib.hs @@ -0,0 +1,6 @@ +module MyLib (someFunc) where + +import Data.List.Split + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-tests/cabal-add-tests.cabal b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-tests/cabal-add-tests.cabal new file mode 100644 index 0000000000..d217f8c4d5 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-tests/cabal-add-tests.cabal @@ -0,0 +1,18 @@ +cabal-version: 2.4 +name: cabal-add-tests +version: 0.1.0.0 +license: NONE +author: George Gerasev +maintainer: george30032002@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +test-suite cabal-add-tests-test + import: warnings + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-tests/test/Main.hs b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-tests/test/Main.hs new file mode 100644 index 0000000000..e5c42398f2 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-tests/test/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Data.List.Split + +main :: IO () +main = putStrLn "Test suite not yet implemented." diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal.project b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal.project new file mode 100644 index 0000000000..dfa2feed39 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal.project @@ -0,0 +1,4 @@ +packages: cabal-add-exe + cabal-add-lib + cabal-add-tests + cabal-add-bench diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/hie.yaml b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/hie.yaml new file mode 100644 index 0000000000..f0c7014d7f --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/common-section/simple-with-common.cabal b/plugins/hls-cabal-plugin/test/testdata/goto-definition/common-section/simple-with-common.cabal new file mode 100644 index 0000000000..c71e369b30 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/common-section/simple-with-common.cabal @@ -0,0 +1,62 @@ +cabal-version: 3.0 +name: simple-cabal +version: 0.1.0.0 +license: MIT + +-- Range : (6, 0) - (7, 22) +common warnings-0 + ghc-options: -Wall + +-- Range : (10, 0) - (17, 40) +common warnings-1 + ghc-options: -Wall + -Wredundant-constraints + -Wunused-packages + + -Wno-name-shadowing + + -Wno-unticked-promoted-constructors + +-- Range : (20, 0) - (23, 34) +common warnings-2 + ghc-options: -Wall + -Wredundant-constraints + -Wunused-packages + +library + + import: warnings-0 +-- ^ Position: (27, 16), middle of identifier + + import: warnings-1 +-- ^ Position: (30, 12), left of identifier + + import: warnings-2 +-- ^ Position: (33, 22), right of identifier + + import: warnings-0 +-- ^ Position: (36, 20), left of '-' in identifier + + import: warnings-1 +-- ^ Position: (39, 19), right of "-" in identifier + + import: warnings-2,warnings-1,warnings-0 +-- ^ Position: (42, 16), identifier in identifier list + + import: warnings-2,warnings-1,warnings-0 +-- ^ Position: (45, 33), left of ',' right of identifier + + import: warnings-2,warnings-1,warnings-0 +-- ^ Position: (48, 34), right of ',' left of identifier + + import: warnings-2, warnings-1,warnings-0 +-- ^ Position: (51, 37), right of ',' left of space + + import: warnings-0 +-- ^ Position: (54, 11), right of ':' left of space + + import: warnings-0 +-- ^ Position: (57, 8), not a definition + + -- EOL +-- ^ Position: (59, 7), empty space \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/module-examples.cabal b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/module-examples.cabal new file mode 100644 index 0000000000..24c2bb854e --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/module-examples.cabal @@ -0,0 +1,51 @@ +cabal-version: 3.0 +name: module-examples +version: 0.1.0.0 + + +library + exposed-modules: Library.Lib +-- ^ Position: (6, 22) +-- ^ Position: (6, 33) + other-modules: Library.Other.OtherLib +-- ^ Position: (9, 22) +-- ^ Position: (9, 44) + + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 + +executable exec + hs-source-dirs: src/exe + main-is: Main.hs + build-depends: base + other-modules: + Config +-- ^ Position: (22, 8) +-- ^ Position: (22, 14) + +test-suite module-examples-test + type: exitcode-stdio-1.0 + hs-source-dirs: src/test + main-is: Main.hs + other-modules: + Config +-- ^ Position: (31, 8) +-- ^ Position: (31, 14) + Library +-- ^ Position: (34, 8) +-- ^ Position: (34, 15) + build-depends: base + +benchmark benchmark + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: src/bench + build-depends: base + other-modules: + Config +-- ^ Position: (45, 28) +-- ^ Position: (45, 34) + NotExistent +-- ^ Position: (48, 19) +-- ^ Position: (48, 30) diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Lib.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Lib.hs new file mode 100644 index 0000000000..e2cde3780b --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Lib.hs @@ -0,0 +1 @@ +module Library.Lib where diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Other/OtherLib.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Other/OtherLib.hs new file mode 100644 index 0000000000..625be777dc --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Other/OtherLib.hs @@ -0,0 +1 @@ +module Library.Other.OtherLib where diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Config.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Config.hs new file mode 100644 index 0000000000..6ea268c214 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Config.hs @@ -0,0 +1 @@ +module Config where diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Main.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Main.hs new file mode 100644 index 0000000000..6640b61707 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = undefined \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Config.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Config.hs new file mode 100644 index 0000000000..3a2489708e --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Config.hs @@ -0,0 +1 @@ +module Confing where \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Main.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Main.hs new file mode 100644 index 0000000000..6640b61707 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = undefined \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Config.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Config.hs new file mode 100644 index 0000000000..39e39fc16a --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Config.hs @@ -0,0 +1 @@ +module Config where \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Library.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Library.hs new file mode 100644 index 0000000000..7899749de8 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Library.hs @@ -0,0 +1 @@ +module Library where \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Main.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Main.hs new file mode 100644 index 0000000000..e69de29bb2 diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/simple-with-common.cabal b/plugins/hls-cabal-plugin/test/testdata/goto-definition/simple-with-common.cabal new file mode 100644 index 0000000000..c71e369b30 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/simple-with-common.cabal @@ -0,0 +1,62 @@ +cabal-version: 3.0 +name: simple-cabal +version: 0.1.0.0 +license: MIT + +-- Range : (6, 0) - (7, 22) +common warnings-0 + ghc-options: -Wall + +-- Range : (10, 0) - (17, 40) +common warnings-1 + ghc-options: -Wall + -Wredundant-constraints + -Wunused-packages + + -Wno-name-shadowing + + -Wno-unticked-promoted-constructors + +-- Range : (20, 0) - (23, 34) +common warnings-2 + ghc-options: -Wall + -Wredundant-constraints + -Wunused-packages + +library + + import: warnings-0 +-- ^ Position: (27, 16), middle of identifier + + import: warnings-1 +-- ^ Position: (30, 12), left of identifier + + import: warnings-2 +-- ^ Position: (33, 22), right of identifier + + import: warnings-0 +-- ^ Position: (36, 20), left of '-' in identifier + + import: warnings-1 +-- ^ Position: (39, 19), right of "-" in identifier + + import: warnings-2,warnings-1,warnings-0 +-- ^ Position: (42, 16), identifier in identifier list + + import: warnings-2,warnings-1,warnings-0 +-- ^ Position: (45, 33), left of ',' right of identifier + + import: warnings-2,warnings-1,warnings-0 +-- ^ Position: (48, 34), right of ',' left of identifier + + import: warnings-2, warnings-1,warnings-0 +-- ^ Position: (51, 37), right of ',' left of space + + import: warnings-0 +-- ^ Position: (54, 11), right of ':' left of space + + import: warnings-0 +-- ^ Position: (57, 8), not a definition + + -- EOL +-- ^ Position: (59, 7), empty space \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/hie.yaml b/plugins/hls-cabal-plugin/test/testdata/hie.yaml new file mode 100644 index 0000000000..95d800026a --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: + arguments: [] \ No newline at end of file diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index a1a2017c8d..2ac8f8a692 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -1,90 +1,114 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.ExplicitFields ( descriptor , Log ) where -import Control.Lens ((&), (?~), (^.)) -import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Lens ((&), (?~), (^.)) +import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Maybe -import Data.Aeson (toJSON) -import Data.Generics (GenericQ, everything, - everythingBut, extQ, mkQ) -import qualified Data.IntMap.Strict as IntMap -import qualified Data.Map as Map -import Data.Maybe (fromMaybe, isJust, - maybeToList) -import Data.Text (Text) -import Data.Unique (hashUnique, newUnique) - -import Control.Monad (replicateM) -import Development.IDE (IdeState, Pretty (..), Range, - Recorder (..), Rules, - WithPriority (..), - defineNoDiagnostics, - realSrcSpanToRange, viaShow) +import Data.Generics (GenericQ, everything, + everythingBut, extQ, mkQ) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isJust, + mapMaybe, maybeToList) +import Data.Text (Text) +import Data.Unique (hashUnique, newUnique) + +import Control.Monad (replicateM) +import Control.Monad.Trans.Class (lift) +import Data.Aeson (ToJSON (toJSON)) +import Data.List (find, intersperse) +import qualified Data.Text as T +import Development.IDE (IdeState, + Location (Location), + Pretty (..), + Range (Range, _end, _start), + Recorder (..), Rules, + WithPriority (..), + defineNoDiagnostics, + getDefinition, printName, + realSrcSpanToRange, + shakeExtras, + srcSpanToRange, viaShow) import Development.IDE.Core.PluginUtils -import Development.IDE.Core.RuleTypes (TcModuleResult (..), - TypeCheck (..)) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat (HsConDetails (RecCon), - HsExpr (XExpr), - HsRecFields (..), LPat, - Outputable, getLoc, - recDotDot, unLoc) -import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), - GhcPass, - HsExpr (RecordCon, rcon_flds), - HsRecField, LHsExpr, - LocatedA, Name, Pass (..), - Pat (..), RealSrcSpan, - UniqFM, conPatDetails, - emptyUFM, hfbPun, hfbRHS, - hs_valds, lookupUFM, - mapConPatDetail, mapLoc, - pattern RealSrcSpan, - plusUFM_C, unitUFM) -import Development.IDE.GHC.Util (getExtensions, - printOutputable) -import Development.IDE.Graph (RuleResult) -import Development.IDE.Graph.Classes (Hashable, NFData) -import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), - getFirstPragma, - insertNewPragma) -import GHC.Generics (Generic) -import Ide.Logger (Priority (..), cmapWithPrio, - logWith, (<+>)) -import Ide.Plugin.Error (PluginError (PluginInternalError, PluginStaleResolve), - getNormalizedFilePathE, - handleMaybe) -import Ide.Plugin.RangeMap (RangeMap) -import qualified Ide.Plugin.RangeMap as RangeMap -import Ide.Plugin.Resolve (mkCodeActionWithResolveAndCommand) -import Ide.Types (PluginDescriptor (..), - PluginId (..), - PluginMethodHandler, - ResolveFunction, - defaultPluginDescriptor) -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message (Method (..)) -import Language.LSP.Protocol.Types (CodeAction (..), - CodeActionKind (CodeActionKind_RefactorRewrite), - CodeActionParams (..), - Command, TextEdit (..), - WorkspaceEdit (WorkspaceEdit), - type (|?) (InL, InR)) +import Development.IDE.Core.PositionMapping (toCurrentRange) +import Development.IDE.Core.RuleTypes (TcModuleResult (..), + TypeCheck (..)) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat (FieldOcc (FieldOcc), + GhcPass, GhcTc, + HasSrcSpan (getLoc), + HsConDetails (RecCon), + HsExpr (HsVar, XExpr), + HsFieldBind (hfbLHS), + HsRecFields (..), + Identifier, LPat, + NamedThing (getName), + Outputable, + TcGblEnv (tcg_binds), + Var (varName), + XXExprGhcTc (..), + recDotDot, unLoc) +import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), + HsExpr (RecordCon, rcon_flds), + HsRecField, LHsExpr, + LocatedA, Name, Pat (..), + RealSrcSpan, UniqFM, + conPatDetails, emptyUFM, + hfbPun, hfbRHS, + lookupUFM, + mapConPatDetail, mapLoc, + pattern RealSrcSpan, + plusUFM_C, unitUFM) +import Development.IDE.GHC.Util (getExtensions, + printOutputable) +import Development.IDE.Graph (RuleResult) +import Development.IDE.Graph.Classes (Hashable, NFData) +import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), + getFirstPragma, + insertNewPragma) +import GHC.Generics (Generic) +import Ide.Logger (Priority (..), + cmapWithPrio, logWith, + (<+>)) +import Ide.Plugin.Error (PluginError (PluginInternalError, PluginStaleResolve), + getNormalizedFilePathE, + handleMaybe) +import Ide.Plugin.RangeMap (RangeMap) +import qualified Ide.Plugin.RangeMap as RangeMap +import Ide.Plugin.Resolve (mkCodeActionWithResolveAndCommand) +import Ide.Types (PluginDescriptor (..), + PluginId (..), + PluginMethodHandler, + ResolveFunction, + defaultPluginDescriptor, + mkPluginHandler) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (..), + SMethod (SMethod_TextDocumentInlayHint)) +import Language.LSP.Protocol.Types (CodeAction (..), + CodeActionKind (CodeActionKind_RefactorRewrite), + CodeActionParams (CodeActionParams), + Command, InlayHint (..), + InlayHintLabelPart (InlayHintLabelPart), + InlayHintParams (InlayHintParams, _range, _textDocument), + TextDocumentIdentifier (TextDocumentIdentifier), + TextEdit (TextEdit), + WorkspaceEdit (WorkspaceEdit), + type (|?) (InL, InR)) #if __GLASGOW_HASKELL__ < 910 -import Development.IDE.GHC.Compat (HsExpansion (HsExpanded)) -#else -import Development.IDE.GHC.Compat (XXExprGhcRn (..)) +import Development.IDE.GHC.Compat (HsExpansion (HsExpanded)) #endif data Log @@ -105,8 +129,9 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta descriptor recorder plId = let resolveRecorder = cmapWithPrio LogResolve recorder (carCommands, caHandlers) = mkCodeActionWithResolveAndCommand resolveRecorder plId codeActionProvider codeActionResolveProvider + ihHandlers = mkPluginHandler SMethod_TextDocumentInlayHint (inlayHintProvider recorder) in (defaultPluginDescriptor plId "Provides a code action to make record wildcards explicit") - { pluginHandlers = caHandlers + { pluginHandlers = caHandlers <> ihHandlers , pluginCommands = carCommands , pluginRules = collectRecordsRule recorder *> collectNamesRule } @@ -120,12 +145,9 @@ codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do let actions = map (mkCodeAction enabledExtensions) (RangeMap.filterByRange range crCodeActions) pure $ InL actions where - mkCodeAction :: [Extension] -> Int -> Command |? CodeAction - mkCodeAction exts uid = InR CodeAction - { _title = "Expand record wildcard" - <> if NamedFieldPuns `elem` exts - then mempty - else " (needs extension: NamedFieldPuns)" + mkCodeAction :: [Extension] -> Int -> Command |? CodeAction + mkCodeAction exts uid = InR CodeAction + { _title = mkTitle exts , _kind = Just CodeActionKind_RefactorRewrite , _diagnostics = Nothing , _isPreferred = Nothing @@ -144,17 +166,76 @@ codeActionResolveProvider ideState pId ca uri uid = do -- that this resolve is stale. record <- handleMaybe PluginStaleResolve $ IntMap.lookup uid crCodeActionResolve -- We should never fail to render - rendered <- handleMaybe (PluginInternalError "Failed to render") $ renderRecordInfo nameMap record + rendered <- handleMaybe (PluginInternalError "Failed to render") $ renderRecordInfoAsTextEdit nameMap record let edits = [rendered] <> maybeToList (pragmaEdit enabledExtensions pragma) pure $ ca & L.edit ?~ mkWorkspaceEdit edits where mkWorkspaceEdit ::[TextEdit] -> WorkspaceEdit mkWorkspaceEdit edits = WorkspaceEdit (Just $ Map.singleton uri edits) Nothing Nothing - pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit - pragmaEdit exts pragma = if NamedFieldPuns `elem` exts - then Nothing - else Just $ insertNewPragma pragma NamedFieldPuns + +inlayHintProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint +inlayHintProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do + nfp <- getNormalizedFilePathE uri + pragma <- getFirstPragma pId state nfp + runIdeActionE "ExplicitFields.CollectRecords" (shakeExtras state) $ do + (crr@CRR {crCodeActions, crCodeActionResolve}, pm) <- useWithStaleFastE CollectRecords nfp + let -- Get all records with dotdot in current nfp + records = [ record + | Just range <- [toCurrentRange pm visibleRange] + , uid <- RangeMap.elementsInRange range crCodeActions + , Just record <- [IntMap.lookup uid crCodeActionResolve] ] + -- Get the definition of each dotdot of record + locations = [ getDefinition nfp pos + | record <- records + , pos <- maybeToList $ fmap _start $ recordInfoToDotDotRange record ] + defnLocsList <- lift $ sequence locations + pure $ InL $ mapMaybe (mkInlayHints crr pragma) (zip defnLocsList records) + where + mkInlayHints :: CollectRecordsResult -> NextPragmaInfo -> (Maybe [(Location, Identifier)], RecordInfo) -> Maybe InlayHint + mkInlayHints CRR {enabledExtensions, nameMap} pragma (defnLocs, record) = + let range = recordInfoToDotDotRange record + textEdits = maybeToList (renderRecordInfoAsTextEdit nameMap record) + <> maybeToList (pragmaEdit enabledExtensions pragma) + names = renderRecordInfoAsLabelName record + in do + end <- fmap _end range + names' <- names + defnLocs' <- defnLocs + let excludeDotDot (Location _ (Range _ end')) = end' /= end + -- find location from dotdot definitions that name equal to label name + findLocation name locations = + let -- filter locations not within dotdot range + filteredLocations = filter (excludeDotDot . fst) locations + -- checks if 'a' is equal to 'Name' if the 'Either' is 'Right a', otherwise return 'False' + nameEq = either (const False) ((==) name) + in fmap fst $ find (nameEq . snd) filteredLocations + valueWithLoc = [ (T.pack $ printName name, findLocation name defnLocs') | name <- names' ] + -- use `, ` to separate labels with definition location + label = intersperse (mkInlayHintLabelPart (", ", Nothing)) $ fmap mkInlayHintLabelPart valueWithLoc + pure $ InlayHint { _position = end -- at the end of dotdot + , _label = InR label + , _kind = Nothing -- neither a type nor a parameter + , _textEdits = Just textEdits -- same as CodeAction + , _tooltip = Just $ InL (mkTitle enabledExtensions) -- same as CodeAction + , _paddingLeft = Just True -- padding after dotdot + , _paddingRight = Nothing + , _data_ = Nothing + } + mkInlayHintLabelPart (value, loc) = InlayHintLabelPart value Nothing loc Nothing + +mkTitle :: [Extension] -> Text +mkTitle exts = "Expand record wildcard" + <> if NamedFieldPuns `elem` exts + then mempty + else " (needs extension: NamedFieldPuns)" + + +pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit +pragmaEdit exts pragma = if NamedFieldPuns `elem` exts + then Nothing + else Just $ insertNewPragma pragma NamedFieldPuns + collectRecordsRule :: Recorder (WithPriority Log) -> Rules () collectRecordsRule recorder = @@ -176,15 +257,11 @@ collectRecordsRule recorder = pure CRR {crCodeActions, crCodeActionResolve, nameMap, enabledExtensions} where getEnabledExtensions :: TcModuleResult -> [Extension] - getEnabledExtensions = getExtensions . tmrParsed + getEnabledExtensions = getExtensions . tmrParsed toRangeAndUnique (uid, recordInfo) = (recordInfoToRange recordInfo, uid) getRecords :: TcModuleResult -> [RecordInfo] -#if __GLASGOW_HASKELL__ < 910 -getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecords valBinds -#else -getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_, _)) = collectRecords valBinds -#endif +getRecords (tcg_binds . tmrTypechecked -> valBinds) = collectRecords valBinds collectNamesRule :: Rules () collectNamesRule = defineNoDiagnostics mempty $ \CollectNames nfp -> runMaybeT $ do @@ -249,8 +326,8 @@ instance Show CollectNamesResult where type instance RuleResult CollectNames = CollectNamesResult data RecordInfo - = RecordInfoPat RealSrcSpan (Pat (GhcPass 'Renamed)) - | RecordInfoCon RealSrcSpan (HsExpr (GhcPass 'Renamed)) + = RecordInfoPat RealSrcSpan (Pat GhcTc) + | RecordInfoCon RealSrcSpan (HsExpr GhcTc) deriving (Generic) instance Pretty RecordInfo where @@ -261,9 +338,19 @@ recordInfoToRange :: RecordInfo -> Range recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss recordInfoToRange (RecordInfoCon ss _) = realSrcSpanToRange ss -renderRecordInfo :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit -renderRecordInfo names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat -renderRecordInfo _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon expr +recordInfoToDotDotRange :: RecordInfo -> Maybe Range +recordInfoToDotDotRange (RecordInfoPat _ (ConPat _ _ (RecCon flds))) = srcSpanToRange . getLoc =<< rec_dotdot flds +recordInfoToDotDotRange (RecordInfoCon _ (RecordCon _ _ flds)) = srcSpanToRange . getLoc =<< rec_dotdot flds +recordInfoToDotDotRange _ = Nothing + +renderRecordInfoAsTextEdit :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit +renderRecordInfoAsTextEdit names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat +renderRecordInfoAsTextEdit _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon expr + +renderRecordInfoAsLabelName :: RecordInfo -> Maybe [Name] +renderRecordInfoAsLabelName (RecordInfoPat _ pat) = showRecordPatFlds pat +renderRecordInfoAsLabelName (RecordInfoCon _ expr) = showRecordConFlds expr + -- | Checks if a 'Name' is referenced in the given map of names. The -- 'hasNonBindingOcc' check is necessary in order to make sure that only the @@ -281,16 +368,16 @@ referencedIn name names = maybe True hasNonBindingOcc $ lookupUFM names name filterReferenced :: (a -> Maybe Name) -> UniqFM Name [Name] -> [a] -> [a] filterReferenced getName names = filter (\x -> maybe True (`referencedIn` names) (getName x)) + preprocessRecordPat - :: p ~ GhcPass 'Renamed + :: p ~ GhcTc => UniqFM Name [Name] -> HsRecFields p (LPat p) -> HsRecFields p (LPat p) -preprocessRecordPat = preprocessRecord (getFieldName . unLoc) - where - getFieldName x = case unLoc (hfbRHS x) of - VarPat _ x' -> Just $ unLoc x' - _ -> Nothing +preprocessRecordPat = preprocessRecord (fmap varName . getFieldName . unLoc) + where getFieldName x = case unLoc (hfbRHS x) of + VarPat _ x' -> Just $ unLoc x' + _ -> Nothing -- No need to check the name usage in the record construction case preprocessRecordCon :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg @@ -333,17 +420,55 @@ preprocessRecord getName names flds = flds { rec_dotdot = Nothing , rec_flds = r punsUsed = filterReferenced getName names puns' rec_flds' = no_puns <> punsUsed -showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => UniqFM Name [Name] -> Pat (GhcPass 'Renamed) -> Maybe Text +processRecordFlds + :: p ~ GhcPass c + => HsRecFields p arg + -> HsRecFields p arg +processRecordFlds flds = flds { rec_dotdot = Nothing , rec_flds = puns' } + where + no_pun_count = fromMaybe (length (rec_flds flds)) (recDotDot flds) + -- Field binds of the explicit form (e.g. `{ a = a' }`) should be drop + puns = drop no_pun_count (rec_flds flds) + -- `hsRecPun` is set to `True` in order to pretty-print the fields as field + -- puns (since there is similar mechanism in the `Outputable` instance as + -- explained above). + puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns + + +showRecordPat :: Outputable (Pat GhcTc) => UniqFM Name [Name] -> Pat GhcTc -> Maybe Text showRecordPat names = fmap printOutputable . mapConPatDetail (\case RecCon flds -> Just $ RecCon (preprocessRecordPat names flds) _ -> Nothing) +showRecordPatFlds :: Pat GhcTc -> Maybe [Name] +showRecordPatFlds (ConPat _ _ args) = do + fields <- processRecCon args + names <- mapM getFieldName (rec_flds fields) + pure names + where + processRecCon (RecCon flds) = Just $ processRecordFlds flds + processRecCon _ = Nothing + getOccName (FieldOcc x _) = Just $ getName x + getOccName _ = Nothing + getFieldName = getOccName . unLoc . hfbLHS . unLoc +showRecordPatFlds _ = Nothing + showRecordCon :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text showRecordCon expr@(RecordCon _ _ flds) = Just $ printOutputable $ expr { rcon_flds = preprocessRecordCon flds } showRecordCon _ = Nothing +showRecordConFlds :: p ~ GhcTc => HsExpr p -> Maybe [Name] +showRecordConFlds (RecordCon _ _ flds) = + mapM getFieldName (rec_flds $ processRecordFlds flds) + where + getVarName (HsVar _ lidp) = Just $ getName lidp + getVarName _ = Nothing + getFieldName = getVarName . unLoc . hfbRHS . unLoc +showRecordConFlds _ = Nothing + + collectRecords :: GenericQ [RecordInfo] collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` getRecCons) @@ -360,7 +485,7 @@ collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` get collectNames :: GenericQ (UniqFM Name [Name]) collectNames = everything (plusUFM_C (<>)) (emptyUFM `mkQ` (\x -> unitUFM x [x])) -getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool) +getRecCons :: LHsExpr GhcTc -> ([RecordInfo], Bool) -- When we stumble upon an occurrence of HsExpanded, we only want to follow a -- single branch. We do this here, by explicitly returning occurrences from -- traversing the original branch, and returning True, which keeps syb from @@ -369,25 +494,23 @@ getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool) -- branch #if __GLASGOW_HASKELL__ >= 910 -getRecCons (unLoc -> XExpr (ExpandedThingRn a _)) = (collectRecords a, True) +getRecCons (unLoc -> XExpr (ExpandedThingTc a _)) = (collectRecords a, False) #else -getRecCons (unLoc -> XExpr (HsExpanded a _)) = (collectRecords a, True) +getRecCons (unLoc -> XExpr (ExpansionExpr (HsExpanded _ a))) = (collectRecords a, True) #endif getRecCons e@(unLoc -> RecordCon _ _ flds) | isJust (rec_dotdot flds) = (mkRecInfo e, False) where - mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> [RecordInfo] + mkRecInfo :: LHsExpr GhcTc -> [RecordInfo] mkRecInfo expr = [ RecordInfoCon realSpan' (unLoc expr) | RealSrcSpan realSpan' _ <- [ getLoc expr ]] getRecCons _ = ([], False) -getRecPatterns :: LPat (GhcPass 'Renamed) -> ([RecordInfo], Bool) +getRecPatterns :: LPat GhcTc -> ([RecordInfo], Bool) getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds)) | isJust (rec_dotdot flds) = (mkRecInfo conPat, False) where - mkRecInfo :: LPat (GhcPass 'Renamed) -> [RecordInfo] + mkRecInfo :: LPat GhcTc -> [RecordInfo] mkRecInfo pat = [ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]] getRecPatterns _ = ([], False) - - diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index f8e53e44a1..fdfbe4528c 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -4,7 +4,11 @@ module Main ( main ) where import Data.Either (rights) +import Data.Text (Text) import qualified Data.Text as T +import Development.IDE (filePathToUri', + toNormalizedFilePath') +import Development.IDE.Test (canonicalizeUri) import qualified Ide.Plugin.ExplicitFields as ExplicitFields import System.FilePath ((<.>), ()) import Test.Hls @@ -17,21 +21,164 @@ plugin = mkPluginTestDescriptor ExplicitFields.descriptor "explicit-fields" test :: TestTree test = testGroup "explicit-fields" - [ mkTest "WildcardOnly" "WildcardOnly" 12 10 12 20 - , mkTest "Unused" "Unused" 12 10 12 20 - , mkTest "Unused2" "Unused2" 12 10 12 20 - , mkTest "WithPun" "WithPun" 13 10 13 25 - , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 - , mkTest "Mixed" "Mixed" 14 10 14 37 - , mkTest "Construction" "Construction" 16 5 16 15 - , mkTest "HsExpanded1" "HsExpanded1" 17 10 17 20 - , mkTest "HsExpanded2" "HsExpanded2" 23 10 23 22 - , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 - , mkTestNoAction "Puns" "Puns" 12 10 12 31 - , mkTestNoAction "Infix" "Infix" 11 11 11 31 - , mkTestNoAction "Prefix" "Prefix" 10 11 10 28 + [ testGroup "code actions" + [ mkTest "WildcardOnly" "WildcardOnly" 12 10 12 20 + , mkTest "Unused" "Unused" 12 10 12 20 + , mkTest "Unused2" "Unused2" 12 10 12 20 + , mkTest "WithPun" "WithPun" 13 10 13 25 + , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 + , mkTest "Mixed" "Mixed" 14 10 14 37 + , mkTest "Construction" "Construction" 16 5 16 15 + , mkTest "HsExpanded1" "HsExpanded1" 17 10 17 20 + , mkTest "HsExpanded2" "HsExpanded2" 23 10 23 22 + , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 + , mkTestNoAction "Puns" "Puns" 12 10 12 31 + , mkTestNoAction "Infix" "Infix" 11 11 11 31 + , mkTestNoAction "Prefix" "Prefix" 10 11 10 28 + ] + , testGroup "inlay hints" + [ mkInlayHintsTest "Construction" 16 $ \ih -> do + let mkLabelPart' = mkLabelPart "Construction" + foo <- mkLabelPart' 13 6 "foo" + bar <- mkLabelPart' 14 6 "bar" + baz <- mkLabelPart' 15 6 "baz" + (@?=) ih + [defInlayHint { _position = Position 16 14 + , _label = InR [ foo, commaPart + , bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 16 5 15 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "HsExpanded1" 17 $ \ih -> do + let mkLabelPart' = mkLabelPart "HsExpanded1" + foo <- mkLabelPart' 11 4 "foo" + (@?=) ih + [defInlayHint { _position = Position 17 19 + , _label = InR [ foo ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo}" 17 10 20 ] + , _tooltip = Just $ InL "Expand record wildcard" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "HsExpanded2" 23 $ \ih -> do + let mkLabelPart' = mkLabelPart "HsExpanded2" + bar <- mkLabelPart' 14 4 "bar" + (@?=) ih + [defInlayHint { _position = Position 23 21 + , _label = InR [ bar ] + , _textEdits = Just [ mkLineTextEdit "YourRec {bar}" 23 10 22 ] + , _tooltip = Just $ InL "Expand record wildcard" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "Mixed" 14 $ \ih -> do + let mkLabelPart' = mkLabelPart "Mixed" + baz <- mkLabelPart' 9 4 "baz" + quux <- mkLabelPart' 10 4 "quux" + (@?=) ih + [defInlayHint { _position = Position 14 36 + , _label = InR [ baz, commaPart + , quux + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar = bar', baz}" 14 10 37 ] + , _tooltip = Just $ InL "Expand record wildcard" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "Unused" 12 $ \ih -> do + let mkLabelPart' = mkLabelPart "Unused" + foo <- mkLabelPart' 6 4 "foo" + bar <- mkLabelPart' 7 4 "bar" + baz <- mkLabelPart' 8 4 "baz" + (@?=) ih + [defInlayHint { _position = Position 12 19 + , _label = InR [ foo, commaPart + , bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar}" 12 10 20 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "Unused2" 12 $ \ih -> do + let mkLabelPart' = mkLabelPart "Unused2" + foo <- mkLabelPart' 6 4 "foo" + bar <- mkLabelPart' 7 4 "bar" + baz <- mkLabelPart' 8 4 "baz" + (@?=) ih + [defInlayHint { _position = Position 12 19 + , _label = InR [ foo, commaPart + , bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar}" 12 10 20 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "WildcardOnly" 12 $ \ih -> do + let mkLabelPart' = mkLabelPart "WildcardOnly" + foo <- mkLabelPart' 6 4 "foo" + bar <- mkLabelPart' 7 4 "bar" + baz <- mkLabelPart' 8 4 "baz" + (@?=) ih + [defInlayHint { _position = Position 12 19 + , _label = InR [ foo, commaPart + , bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 12 10 20 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "WithExplicitBind" 12 $ \ih -> do + let mkLabelPart' = mkLabelPart "WithExplicitBind" + bar <- mkLabelPart' 7 4 "bar" + baz <- mkLabelPart' 8 4 "baz" + (@?=) ih + [defInlayHint { _position = Position 12 31 + , _label = InR [ bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo = foo', bar, baz}" 12 10 32 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "WithPun" 13 $ \ih -> do + let mkLabelPart' = mkLabelPart "WithPun" + bar <- mkLabelPart' 8 4 "bar" + baz <- mkLabelPart' 9 4 "baz" + (@?=) ih + [defInlayHint { _position = Position 13 24 + , _label = InR [ bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 13 10 25 ] + , _tooltip = Just $ InL "Expand record wildcard" + , _paddingLeft = Just True + }] + ] ] +mkInlayHintsTest :: FilePath -> UInt -> ([InlayHint] -> Assertion) -> TestTree +mkInlayHintsTest fp line assert = + testCase fp $ + runSessionWithServer def plugin testDataDir $ do + doc <- openDoc (fp ++ ".hs") "haskell" + inlayHints <- getInlayHints doc (lineRange line) + liftIO $ assert inlayHints + where + lineRange line = Range (Position line 0) (Position line 1000) + mkTestNoAction :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree mkTestNoAction title fp x1 y1 x2 y2 = testCase title $ @@ -66,5 +213,54 @@ isExplicitFieldsCodeAction :: CodeAction -> Bool isExplicitFieldsCodeAction CodeAction {_title} = "Expand record wildcard" `T.isPrefixOf` _title +defInlayHint :: InlayHint +defInlayHint = + InlayHint + { _position = Position 0 0 + , _label = InR [] + , _kind = Nothing + , _textEdits = Nothing + , _tooltip = Nothing + , _paddingLeft = Nothing + , _paddingRight = Nothing + , _data_ = Nothing + } + +mkLabelPart :: FilePath -> UInt -> UInt -> Text -> IO InlayHintLabelPart +mkLabelPart fp line start value = do + uri' <- uri + pure $ InlayHintLabelPart { _location = Just (location uri' line start) + , _value = value + , _tooltip = Nothing + , _command = Nothing + } + where + toUri = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' + uri = canonicalizeUri $ toUri (testDataDir (fp ++ ".hs")) + location uri line char = Location uri (Range (Position line char) (Position line (char + (fromIntegral $ T.length value)))) + +commaPart :: InlayHintLabelPart +commaPart = + InlayHintLabelPart + { _location = Nothing + , _value = ", " + , _tooltip = Nothing + , _command = Nothing + } + +mkLineTextEdit :: Text -> UInt -> UInt -> UInt -> TextEdit +mkLineTextEdit newText line x y = + TextEdit + { _range = Range (Position line x) (Position line y) + , _newText = newText + } + +mkPragmaTextEdit :: UInt -> TextEdit +mkPragmaTextEdit line = + TextEdit + { _range = Range (Position line 0) (Position line 0) + , _newText = "{-# LANGUAGE NamedFieldPuns #-}\n" + } + testDataDir :: FilePath testDataDir = "plugins" "hls-explicit-record-fields-plugin" "test" "testdata" diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index f08ae187cd..87a1af7392 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -152,6 +152,7 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins allPlugins = #if hls_cabal let pId = "cabal" in Cabal.descriptor (pluginRecorder pId) pId : + let caId = "cabalHaskellIntegration" in Cabal.haskellInteractionDescriptor (pluginRecorder caId) caId : #endif #if hls_pragmas Pragmas.suggestPragmaDescriptor "pragmas-suggest" : diff --git a/stack-lts22.yaml b/stack-lts22.yaml index 80007a898c..ecd17a99c2 100644 --- a/stack-lts22.yaml +++ b/stack-lts22.yaml @@ -37,6 +37,9 @@ extra-deps: - trial-optparse-applicative-0.0.0.0 - trial-tomland-0.0.0.0 - validation-selective-0.2.0.0 + - cabal-add-0.1 + - cabal-install-parsers-0.6.1.1 + configure-options: ghcide: @@ -51,6 +54,8 @@ flags: ghc-lib: true retrie: BuildExecutable: false + cabal-add: + cabal-syntax: true nix: packages: [icu libcxx zlib] diff --git a/stack.yaml b/stack.yaml index 8df73f646b..8df29e1b00 100644 --- a/stack.yaml +++ b/stack.yaml @@ -38,6 +38,8 @@ extra-deps: - trial-0.0.0.0 - trial-optparse-applicative-0.0.0.0 - trial-tomland-0.0.0.0 + - cabal-add-0.1 + - cabal-install-parsers-0.6.1.1 configure-options: ghcide: @@ -52,6 +54,8 @@ flags: ghc-lib: true retrie: BuildExecutable: false + cabal-add: + cabal-syntax: true nix: packages: [icu libcxx zlib] diff --git a/test/testdata/schema/ghc94/default-config.golden.json b/test/testdata/schema/ghc94/default-config.golden.json index 5f881ff00e..3419159603 100644 --- a/test/testdata/schema/ghc94/default-config.golden.json +++ b/test/testdata/schema/ghc94/default-config.golden.json @@ -24,6 +24,9 @@ "path": "cabal-gild" } }, + "cabalHaskellIntegration": { + "globalOn": true + }, "callHierarchy": { "globalOn": true }, @@ -42,7 +45,8 @@ "globalOn": true }, "explicit-fields": { - "globalOn": true + "codeActionsOn": true, + "inlayHintsOn": true }, "explicit-fixity": { "globalOn": true diff --git a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json index 5da4a27dd6..17693c70a8 100644 --- a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json @@ -41,6 +41,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.cabalHaskellIntegration.globalOn": { + "default": true, + "description": "Enables cabalHaskellIntegration plugin", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.callHierarchy.globalOn": { "default": true, "description": "Enables callHierarchy plugin", @@ -83,9 +89,15 @@ "scope": "resource", "type": "boolean" }, - "haskell.plugin.explicit-fields.globalOn": { + "haskell.plugin.explicit-fields.codeActionsOn": { + "default": true, + "description": "Enables explicit-fields code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fields.inlayHintsOn": { "default": true, - "description": "Enables explicit-fields plugin", + "description": "Enables explicit-fields inlay hints", "scope": "resource", "type": "boolean" }, diff --git a/test/testdata/schema/ghc96/default-config.golden.json b/test/testdata/schema/ghc96/default-config.golden.json index 5f881ff00e..3419159603 100644 --- a/test/testdata/schema/ghc96/default-config.golden.json +++ b/test/testdata/schema/ghc96/default-config.golden.json @@ -24,6 +24,9 @@ "path": "cabal-gild" } }, + "cabalHaskellIntegration": { + "globalOn": true + }, "callHierarchy": { "globalOn": true }, @@ -42,7 +45,8 @@ "globalOn": true }, "explicit-fields": { - "globalOn": true + "codeActionsOn": true, + "inlayHintsOn": true }, "explicit-fixity": { "globalOn": true diff --git a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json index 5da4a27dd6..17693c70a8 100644 --- a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json @@ -41,6 +41,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.cabalHaskellIntegration.globalOn": { + "default": true, + "description": "Enables cabalHaskellIntegration plugin", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.callHierarchy.globalOn": { "default": true, "description": "Enables callHierarchy plugin", @@ -83,9 +89,15 @@ "scope": "resource", "type": "boolean" }, - "haskell.plugin.explicit-fields.globalOn": { + "haskell.plugin.explicit-fields.codeActionsOn": { + "default": true, + "description": "Enables explicit-fields code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fields.inlayHintsOn": { "default": true, - "description": "Enables explicit-fields plugin", + "description": "Enables explicit-fields inlay hints", "scope": "resource", "type": "boolean" }, diff --git a/test/testdata/schema/ghc98/default-config.golden.json b/test/testdata/schema/ghc98/default-config.golden.json index 5f881ff00e..3419159603 100644 --- a/test/testdata/schema/ghc98/default-config.golden.json +++ b/test/testdata/schema/ghc98/default-config.golden.json @@ -24,6 +24,9 @@ "path": "cabal-gild" } }, + "cabalHaskellIntegration": { + "globalOn": true + }, "callHierarchy": { "globalOn": true }, @@ -42,7 +45,8 @@ "globalOn": true }, "explicit-fields": { - "globalOn": true + "codeActionsOn": true, + "inlayHintsOn": true }, "explicit-fixity": { "globalOn": true diff --git a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json index 5da4a27dd6..17693c70a8 100644 --- a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json @@ -41,6 +41,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.cabalHaskellIntegration.globalOn": { + "default": true, + "description": "Enables cabalHaskellIntegration plugin", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.callHierarchy.globalOn": { "default": true, "description": "Enables callHierarchy plugin", @@ -83,9 +89,15 @@ "scope": "resource", "type": "boolean" }, - "haskell.plugin.explicit-fields.globalOn": { + "haskell.plugin.explicit-fields.codeActionsOn": { + "default": true, + "description": "Enables explicit-fields code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fields.inlayHintsOn": { "default": true, - "description": "Enables explicit-fields plugin", + "description": "Enables explicit-fields inlay hints", "scope": "resource", "type": "boolean" },