diff --git a/cabal.project b/cabal.project index 3d43dff2f4..ae657192af 100644 --- a/cabal.project +++ b/cabal.project @@ -7,8 +7,7 @@ packages: ./hls-plugin-api ./hls-test-utils - -index-state: 2025-06-07T14:57:40Z +index-state: 2025-06-17T00:00:00Z tests: True test-show-details: direct diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index f49c619ec1..108f9e9da1 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -254,8 +254,13 @@ library hls-cabal-plugin Ide.Plugin.Cabal.Completion.Types Ide.Plugin.Cabal.Definition Ide.Plugin.Cabal.FieldSuggest + Ide.Plugin.Cabal.Files + Ide.Plugin.Cabal.OfInterest Ide.Plugin.Cabal.LicenseSuggest - Ide.Plugin.Cabal.CabalAdd + Ide.Plugin.Cabal.Rules + Ide.Plugin.Cabal.CabalAdd.Command + Ide.Plugin.Cabal.CabalAdd.CodeAction + Ide.Plugin.Cabal.CabalAdd.Types Ide.Plugin.Cabal.Orphans Ide.Plugin.Cabal.Outline Ide.Plugin.Cabal.Parse @@ -276,14 +281,14 @@ library hls-cabal-plugin , lens , lsp ^>=2.7 , lsp-types ^>=2.3 + , mtl , regex-tdfa ^>=1.3.1 , text , text-rope , transformers , unordered-containers >=0.2.10.0 , containers - , cabal-add - , process + , cabal-add ^>=0.2 , aeson , Cabal , pretty @@ -315,7 +320,6 @@ test-suite hls-cabal-plugin-tests , lens , lsp-types , text - , hls-plugin-api ----------------------------- -- class plugin diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 9a56467f3f..636a5c689f 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -6,61 +6,48 @@ module Ide.Plugin.Cabal (descriptor, haskellInteractionDescriptor, Log (..)) where -import Control.Concurrent.Strict -import Control.DeepSeq import Control.Lens ((^.)) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (runMaybeT) -import qualified Data.ByteString as BS -import Data.Hashable import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap import qualified Data.List as List -import qualified Data.List.NonEmpty as NE import qualified Data.Maybe as Maybe -import Data.Proxy import qualified Data.Text () import qualified Data.Text as T -import qualified Data.Text.Encoding as Encoding -import Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE as D import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils import Development.IDE.Core.Shake (restartShakeSession) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Graph (Key, - alwaysRerun) +import Development.IDE.Graph (Key) import Development.IDE.LSP.HoverDefinition (foundHover) import qualified Development.IDE.Plugin.Completions.Logic as Ghcide import Development.IDE.Types.Shake (toKey) -import qualified Distribution.CabalSpecVersion as Cabal import qualified Distribution.Fields as Syntax import Distribution.Package (Dependency) import Distribution.PackageDescription (allBuildDepends, depPkgName, unPackageName) import Distribution.PackageDescription.Configuration (flattenPackageDescription) -import Distribution.Parsec.Error import qualified Distribution.Parsec.Position as Syntax -import GHC.Generics -import qualified Ide.Plugin.Cabal.CabalAdd as CabalAdd +import qualified Ide.Plugin.Cabal.CabalAdd.CodeAction as CabalAdd +import qualified Ide.Plugin.Cabal.CabalAdd.Command as CabalAdd import Ide.Plugin.Cabal.Completion.CabalFields as CabalFields import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes import qualified Ide.Plugin.Cabal.Completion.Completions as Completions -import qualified Ide.Plugin.Cabal.Completion.Data as Data import Ide.Plugin.Cabal.Completion.Types (ParseCabalCommonSections (ParseCabalCommonSections), 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.Files as CabalAdd import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest +import qualified Ide.Plugin.Cabal.OfInterest as OfInterest import Ide.Plugin.Cabal.Orphans () import Ide.Plugin.Cabal.Outline -import qualified Ide.Plugin.Cabal.Parse as Parse +import qualified Ide.Plugin.Cabal.Rules as Rules import Ide.Plugin.Error import Ide.Types import qualified Language.LSP.Protocol.Lens as JL @@ -71,7 +58,8 @@ import Text.Regex.TDFA data Log = LogModificationTime NormalizedFilePath FileVersion - | LogShake Shake.Log + | LogRule Rules.Log + | LogOfInterest OfInterest.Log | LogDocOpened Uri | LogDocModified Uri | LogDocSaved Uri @@ -84,7 +72,8 @@ data Log instance Pretty Log where pretty = \case - LogShake log' -> pretty log' + LogRule log' -> pretty log' + LogOfInterest log' -> pretty log' LogModificationTime nfp modTime -> "Modified:" <+> pretty (fromNormalizedFilePath nfp) <+> pretty (show modTime) LogDocOpened uri -> @@ -105,28 +94,32 @@ instance Pretty Log where 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. +{- | 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 + [ mkPluginHandler LSP.SMethod_TextDocumentCodeAction cabalAddPackageCodeAction + , mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ cabalAddModuleCodeAction recorder ] - , pluginCommands = [PluginCommand CabalAdd.cabalAddCommand "add a dependency to a cabal file" (CabalAdd.command cabalAddRecorder)] + , pluginCommands = + [ PluginCommand CabalAdd.cabalAddPackageCommandId "add a dependency to a cabal file" (CabalAdd.addPackageCommand cabalAddRecorder) + , PluginCommand CabalAdd.cabalAddModuleCommandId "add a module to a cabal file" (CabalAdd.addModuleCommand cabalAddRecorder) + ] , pluginRules = pure () , pluginNotificationHandlers = mempty } - where - cabalAddRecorder = cmapWithPrio LogCabalAdd recorder - + where + cabalAddRecorder = cmapWithPrio LogCabalAdd recorder descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultCabalPluginDescriptor plId "Provides a variety of IDE features in cabal files") - { pluginRules = cabalRules recorder plId + { pluginRules = Rules.cabalRules ruleRecorder plId , pluginHandlers = mconcat [ mkPluginHandler LSP.SMethod_TextDocumentCodeAction licenseSuggestCodeAction @@ -143,32 +136,35 @@ descriptor recorder plId = whenUriFile _uri $ \file -> do log' Debug $ LogDocOpened _uri restartCabalShakeSession (shakeExtras ide) vfs file "(opened)" $ - addFileOfInterest recorder ide file Modified{firstOpen = True} + OfInterest.addFileOfInterest ofInterestRecorder ide file Modified{firstOpen = True} , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ \ide vfs _ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocModified _uri restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" $ - addFileOfInterest recorder ide file Modified{firstOpen = False} + OfInterest.addFileOfInterest ofInterestRecorder ide file Modified{firstOpen = False} , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocSaved _uri restartCabalShakeSession (shakeExtras ide) vfs file "(saved)" $ - addFileOfInterest recorder ide file OnDisk + OfInterest.addFileOfInterest ofInterestRecorder ide file OnDisk , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocClosed _uri restartCabalShakeSession (shakeExtras ide) vfs file "(closed)" $ - deleteFileOfInterest recorder ide file + OfInterest.deleteFileOfInterest ofInterestRecorder ide file ] - , pluginConfigDescriptor = defaultConfigDescriptor - { configHasDiagnostics = True - } + , pluginConfigDescriptor = + defaultConfigDescriptor + { configHasDiagnostics = True + } } where log' = logWith recorder + ruleRecorder = cmapWithPrio LogRule recorder + ofInterestRecorder = cmapWithPrio LogOfInterest recorder whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (uriToFilePath uri) $ act . toNormalizedFilePath' @@ -186,146 +182,29 @@ restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> Stri restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do keys <- actionBetweenSession - return (toKey GetModificationTime file:keys) - --- ---------------------------------------------------------------- --- Plugin Rules --- ---------------------------------------------------------------- - -cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules () -cabalRules recorder plId = do - -- Make sure we initialise the cabal files-of-interest. - ofInterestRules recorder - -- Rule to produce diagnostics for cabal files. - define (cmapWithPrio LogShake recorder) $ \ParseCabalFields file -> do - config <- getPluginConfigAction plId - if not (plcGlobalOn config && plcDiagnosticsOn config) - then pure ([], Nothing) - else do - -- whenever this key is marked as dirty (e.g., when a user writes stuff to it), - -- we rerun this rule because this rule *depends* on GetModificationTime. - (t, mCabalSource) <- use_ GetFileContents file - log' Debug $ LogModificationTime file t - contents <- case mCabalSource of - Just sources -> - pure $ Encoding.encodeUtf8 $ Rope.toText sources - Nothing -> do - liftIO $ BS.readFile $ fromNormalizedFilePath file - - case Parse.readCabalFields file contents of - Left _ -> - pure ([], Nothing) - Right fields -> - pure ([], Just fields) - - define (cmapWithPrio LogShake recorder) $ \ParseCabalCommonSections file -> do - fields <- use_ ParseCabalFields file - let commonSections = Maybe.mapMaybe (\case - commonSection@(Syntax.Section (Syntax.Name _ "common") _ _) -> Just commonSection - _ -> Nothing) - fields - pure ([], Just commonSections) - - define (cmapWithPrio LogShake recorder) $ \ParseCabalFile file -> do - config <- getPluginConfigAction plId - if not (plcGlobalOn config && plcDiagnosticsOn config) - then pure ([], Nothing) - else do - -- whenever this key is marked as dirty (e.g., when a user writes stuff to it), - -- we rerun this rule because this rule *depends* on GetModificationTime. - (t, mCabalSource) <- use_ GetFileContents file - log' Debug $ LogModificationTime file t - contents <- case mCabalSource of - Just sources -> - pure $ Encoding.encodeUtf8 $ Rope.toText sources - Nothing -> do - liftIO $ BS.readFile $ fromNormalizedFilePath file - - -- Instead of fully reparsing the sources to get a 'GenericPackageDescription', - -- we would much rather re-use the already parsed results of 'ParseCabalFields'. - -- Unfortunately, Cabal-syntax doesn't expose the function 'parseGenericPackageDescription'' - -- which allows us to resume the parsing pipeline with '[Field Position]'. - (pWarnings, pm) <- liftIO $ Parse.parseCabalFileContents contents - let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings - case pm of - Left (_cabalVersion, pErrorNE) -> do - let regexUnknownCabalBefore310 :: T.Text - -- We don't support the cabal version, this should not be an error, as the - -- user did not do anything wrong. Instead we cast it to a warning - regexUnknownCabalBefore310 = "Unsupported cabal-version [0-9]+.[0-9]*" - regexUnknownCabalVersion :: T.Text - regexUnknownCabalVersion = "Unsupported cabal format version in cabal-version field: [0-9]+.[0-9]+" - unsupportedCabalHelpText = unlines - [ "The used `cabal-version` is not fully supported by this `HLS` binary." - , "Either the `cabal-version` is unknown, or too new for this executable." - , "This means that some functionality might not work as expected." - , "If you face any issues, try downgrading to a supported `cabal-version` or upgrading `HLS` if possible." - , "" - , "Supported versions are: " <> - List.intercalate ", " - (fmap Cabal.showCabalSpecVersion Data.supportedCabalVersions) - ] - errorDiags = - NE.toList $ - NE.map - ( \pe@(PError pos text) -> - if any (text =~) - [ regexUnknownCabalBefore310 - , regexUnknownCabalVersion - ] - then Diagnostics.warningDiagnostic file (Syntax.PWarning Syntax.PWTOther pos $ - unlines - [ text - , unsupportedCabalHelpText - ]) - else Diagnostics.errorDiagnostic file pe - ) - pErrorNE - allDiags = errorDiags <> warningDiags - pure (allDiags, Nothing) - Right gpd -> do - pure (warningDiags, Just gpd) - - action $ do - -- Run the cabal kick. This code always runs when 'shakeRestart' is run. - -- Must be careful to not impede the performance too much. Crucial to - -- a snappy IDE experience. - kick - where - log' = logWith recorder - -{- | This is the kick function for the cabal plugin. -We run this action, whenever we shake session us run/restarted, which triggers -actions to produce diagnostics for cabal files. - -It is paramount that this kick-function can be run quickly, since it is a blocking -function invocation. --} -kick :: Action () -kick = do - files <- HashMap.keys <$> getCabalFilesOfInterestUntracked - Shake.runWithSignal (Proxy @"kick/start/cabal") (Proxy @"kick/done/cabal") files Types.ParseCabalFile + return (toKey GetModificationTime file : keys) -- ---------------------------------------------------------------- -- Code Actions -- ---------------------------------------------------------------- licenseSuggestCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction -licenseSuggestCodeAction ideState _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=diags}) = do +licenseSuggestCodeAction ideState _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics = diags}) = do maxCompls <- fmap maxCompletions . liftIO $ runAction "cabal-plugin.suggestLicense" ideState getClientConfigAction pure $ InL $ diags >>= (fmap InR . LicenseSuggest.licenseErrorAction maxCompls uri) --- | CodeActions for correcting field names with typos in them. --- --- Provides CodeActions that fix typos in both stanzas and top-level field names. --- The suggestions are computed based on the completion context, where we "move" a fake cursor --- to the end of the field name and trigger cabal file completions. The completions are then --- suggested to the user. --- --- TODO: Relying on completions here often does not produce the desired results, we should --- use some sort of fuzzy matching in the future, see issue #4357. +{- | CodeActions for correcting field names with typos in them. + +Provides CodeActions that fix typos in both stanzas and top-level field names. +The suggestions are computed based on the completion context, where we "move" a fake cursor +to the end of the field name and trigger cabal file completions. The completions are then +suggested to the user. + +TODO: Relying on completions here often does not produce the desired results, we should +use some sort of fuzzy matching in the future, see issue #4357. +-} fieldSuggestCodeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction -fieldSuggestCodeAction recorder ide _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics=diags}) = do +fieldSuggestCodeAction recorder ide _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics = diags}) = do mContents <- liftIO $ runAction "cabal-plugin.getUriContents" ide $ getUriContents $ toNormalizedUri uri case (,) <$> mContents <*> uriToFilePath' uri of Nothing -> pure $ InL [] @@ -340,47 +219,83 @@ fieldSuggestCodeAction recorder ide _ (CodeActionParams _ _ (TextDocumentIdentif let fields = Maybe.mapMaybe FieldSuggest.fieldErrorName diags results <- forM fields (getSuggestion fileContents path cabalFields) pure $ InL $ map InR $ concat results - where - getSuggestion fileContents fp cabalFields (fieldName,Diagnostic{ _range=_range@(Range (Position lineNr col) _) }) = do - let -- Compute where we would anticipate the cursor to be. - fakeLspCursorPosition = Position lineNr (col + fromIntegral (T.length fieldName)) - lspPrefixInfo = Ghcide.getCompletionPrefixFromRope fakeLspCursorPosition fileContents - cabalPrefixInfo = Completions.getCabalPrefixInfo fp lspPrefixInfo - completions <- liftIO $ computeCompletionsAt recorder ide cabalPrefixInfo fp cabalFields - 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 + where + getSuggestion fileContents fp cabalFields (fieldName, Diagnostic{_range = _range@(Range (Position lineNr col) _)}) = do + let + -- Compute where we would anticipate the cursor to be. + fakeLspCursorPosition = Position lineNr (col + fromIntegral (T.length fieldName)) + lspPrefixInfo = Ghcide.getCompletionPrefixFromRope fakeLspCursorPosition fileContents + cabalPrefixInfo = Completions.getCabalPrefixInfo fp lspPrefixInfo + completions <- liftIO $ computeCompletionsAt recorder ide cabalPrefixInfo fp cabalFields + let completionTexts = fmap (^. JL.label) completions + pure $ FieldSuggest.fieldErrorAction uri fieldName completionTexts _range + +cabalAddPackageCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction +cabalAddPackageCodeAction state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics = diags}) = do + let suggestions = concatMap CabalAdd.hiddenPackageSuggestion diags case suggestions of [] -> pure $ InL [] - _ -> - case uriToFilePath uri of + _ -> do + haskellFilePath <- uriToFilePathE uri + mbCabalFile <- liftIO $ CabalAdd.findResponsibleCabalFile haskellFilePath + case mbCabalFile of Nothing -> pure $ InL [] - Just haskellFilePath -> do - mbCabalFile <- liftIO $ CabalAdd.findResponsibleCabalFile haskellFilePath - case mbCabalFile of + Just cabalFilePath -> do + verTxtDocId <- + runActionE "cabalAdd.getVersionedTextDoc" state $ + lift $ + getVersionedTextDoc $ + TextDocumentIdentifier (filePathToUri cabalFilePath) + mbGPD <- liftIO $ runAction "cabal.cabal-add" state $ useWithStale ParseCabalFile $ toNormalizedFilePath cabalFilePath + case mbGPD of Nothing -> pure $ InL [] - Just cabalFilePath -> do - verTxtDocId <- runActionE "cabalAdd.getVersionedTextDoc" state $ - lift $ getVersionedTextDoc $ 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 + Just (gpd, _) -> do + actions <- + liftIO $ + CabalAdd.addDependencySuggestCodeAction + plId + verTxtDocId + suggestions + haskellFilePath + cabalFilePath + gpd + pure $ InL $ fmap InR actions + +cabalAddModuleCodeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction +cabalAddModuleCodeAction recorder state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics = diags}) = + case List.find CabalAdd.isUnknownModuleDiagnostic diags of + Just diag -> + do + haskellFilePath <- uriToFilePathE uri + mbCabalFile <- liftIO $ CabalAdd.findResponsibleCabalFile haskellFilePath + case mbCabalFile of + Nothing -> pure $ InL [] + Just cabalFilePath -> do + verTextDocId <- + runActionE "cabalAdd.getVersionedTextDoc" state $ + lift $ + getVersionedTextDoc $ + TextDocumentIdentifier (filePathToUri cabalFilePath) + -- TODO: why useWithStaleE? + (gpd, _) <- runActionE "cabal.cabal-add" state $ useWithStaleE ParseCabalFile $ toNormalizedFilePath cabalFilePath + actions <- + CabalAdd.collectModuleInsertionOptions + (cmapWithPrio LogCabalAdd recorder) + plId + verTextDocId + diag + cabalFilePath + gpd + uri + pure $ InL $ fmap InR actions + Nothing -> pure $ InL [] --- | Handler for hover messages. --- --- Provides a Handler for displaying message on hover. --- If found that the filtered hover message is a dependency, --- adds a Documentation link. +{- | Handler for hover messages. + +Provides a Handler for displaying message on hover. +If found that the filtered hover message is a dependency, +adds a Documentation link. +-} hover :: PluginMethodHandler IdeState LSP.Method_TextDocumentHover hover ide _ msgParam = do nfp <- getNormalizedFilePathE uri @@ -395,111 +310,34 @@ hover ide _ msgParam = do Nothing -> pure $ InR Null Just txt -> if txt `elem` depsNames - then pure $ foundHover (Nothing, [txt <> "\n", documentationText txt]) - else pure $ InR Null - where - cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position) - uri = msgParam ^. JL.textDocument . JL.uri - - dependencyName :: Dependency -> T.Text - dependencyName dep = T.pack $ unPackageName $ depPkgName dep - - -- | Removes version requirements like - -- `==1.0.0.0`, `>= 2.1.1` that could be included in - -- hover message. Assumes that the dependency consists - -- of alphanums with dashes in between. Ends with an alphanum. - -- - -- Examples: - -- >>> filterVersion "imp-deps>=2.1.1" - -- "imp-deps" - filterVersion :: T.Text -> Maybe T.Text - filterVersion msg = getMatch (msg =~ regex) - where - regex :: T.Text - regex = "([a-zA-Z0-9-]*[a-zA-Z0-9])" - - getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> Maybe T.Text - getMatch (_, _, _, [dependency]) = Just dependency - getMatch (_, _, _, _) = Nothing -- impossible case - - documentationText :: T.Text -> T.Text - documentationText package = "[Documentation](https://hackage.haskell.org/package/" <> package <> ")" - - --- ---------------------------------------------------------------- --- Cabal file of Interest rules and global variable --- ---------------------------------------------------------------- - -{- | Cabal files that are currently open in the lsp-client. -Specific actions happen when these files are saved, closed or modified, -such as generating diagnostics, re-parsing, etc... - -We need to store the open files to parse them again if we restart the shake session. -Restarting of the shake session happens whenever these files are modified. --} -newtype OfInterestCabalVar = OfInterestCabalVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) - -instance Shake.IsIdeGlobal OfInterestCabalVar - -data IsCabalFileOfInterest = IsCabalFileOfInterest - deriving (Eq, Show, Generic) -instance Hashable IsCabalFileOfInterest -instance NFData IsCabalFileOfInterest - -type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult - -data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus - deriving (Eq, Show, Generic) -instance Hashable CabalFileOfInterestResult -instance NFData CabalFileOfInterestResult - -{- | The rule that initialises the files of interest state. - -Needs to be run on start-up. --} -ofInterestRules :: Recorder (WithPriority Log) -> Rules () -ofInterestRules recorder = do - Shake.addIdeGlobal . OfInterestCabalVar =<< liftIO (newVar HashMap.empty) - Shake.defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsCabalFileOfInterest f -> do - alwaysRerun - filesOfInterest <- getCabalFilesOfInterestUntracked - let foi = maybe NotCabalFOI IsCabalFOI $ f `HashMap.lookup` filesOfInterest - fp = summarize foi - res = (Just fp, Just foi) - return res - where - summarize NotCabalFOI = BS.singleton 0 - summarize (IsCabalFOI OnDisk) = BS.singleton 1 - summarize (IsCabalFOI (Modified False)) = BS.singleton 2 - summarize (IsCabalFOI (Modified True)) = BS.singleton 3 - -getCabalFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus) -getCabalFilesOfInterestUntracked = do - OfInterestCabalVar var <- Shake.getIdeGlobalAction - liftIO $ readVar var - -addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key] -addFileOfInterest recorder state f v = do - OfInterestCabalVar var <- Shake.getIdeGlobalState state - (prev, files) <- modifyVar var $ \dict -> do - let (prev, new) = HashMap.alterF (,Just v) f dict - pure (new, (prev, new)) - if prev /= Just v - then do - log' Debug $ LogFOI files - return [toKey IsCabalFileOfInterest f] - else return [] - where - log' = logWith recorder - -deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO [Key] -deleteFileOfInterest recorder state f = do - OfInterestCabalVar var <- Shake.getIdeGlobalState state - files <- modifyVar' var $ HashMap.delete f - log' Debug $ LogFOI files - return [toKey IsFileOfInterest f] + then pure $ foundHover (Nothing, [txt <> "\n", documentationText txt]) + else pure $ InR Null where - log' = logWith recorder + cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position) + uri = msgParam ^. JL.textDocument . JL.uri + + dependencyName :: Dependency -> T.Text + dependencyName dep = T.pack $ unPackageName $ depPkgName dep + + -- \| Removes version requirements like + -- `==1.0.0.0`, `>= 2.1.1` that could be included in + -- hover message. Assumes that the dependency consists + -- of alphanums with dashes in between. Ends with an alphanum. + -- + -- Examples: + -- >>> filterVersion "imp-deps>=2.1.1" + -- "imp-deps" + filterVersion :: T.Text -> Maybe T.Text + filterVersion msg = getMatch (msg =~ regex) + where + regex :: T.Text + regex = "([a-zA-Z0-9-]*[a-zA-Z0-9])" + + getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> Maybe T.Text + getMatch (_, _, _, [dependency]) = Just dependency + getMatch (_, _, _, _) = Nothing -- impossible case + documentationText :: T.Text -> T.Text + documentationText package = "[Documentation](https://hackage.haskell.org/package/" <> package <> ")" -- ---------------------------------------------------------------- -- Completion @@ -532,23 +370,24 @@ computeCompletionsAt recorder ide prefInfo fp fields = do Just ctx -> do logWith recorder Debug $ LogCompletionContext ctx pos let completer = Completions.contextToCompleter ctx - let completerData = CompleterTypes.CompleterData - { getLatestGPD = do - -- We decide on useWithStaleFast here, since we mostly care about the file's meta information, - -- thus, a quick response gives us the desired result most of the time. - -- The `withStale` option is very important here, since we often call this rule with invalid cabal files. - mGPD <- runAction "cabal-plugin.modulesCompleter.gpd" ide $ useWithStale ParseCabalFile $ toNormalizedFilePath fp - pure $ fmap fst mGPD - , getCabalCommonSections = runAction "cabal-plugin.commonSections" ide $ use ParseCabalCommonSections $ toNormalizedFilePath fp - , cabalPrefixInfo = prefInfo - , stanzaName = - case fst ctx of - Types.Stanza _ name -> name - _ -> Nothing - } + let completerData = + CompleterTypes.CompleterData + { getLatestGPD = do + -- We decide on useWithStaleFast here, since we mostly care about the file's meta information, + -- thus, a quick response gives us the desired result most of the time. + -- The `withStale` option is very important here, since we often call this rule with invalid cabal files. + mGPD <- runAction "cabal-plugin.modulesCompleter.gpd" ide $ useWithStale ParseCabalFile $ toNormalizedFilePath fp + pure $ fmap fst mGPD + , getCabalCommonSections = runAction "cabal-plugin.commonSections" ide $ use ParseCabalCommonSections $ toNormalizedFilePath fp + , cabalPrefixInfo = prefInfo + , stanzaName = + case fst ctx of + Types.Stanza _ name -> name + _ -> Nothing + } completions <- completer completerRecorder completerData pure completions - where - pos = Types.completionCursorPosition prefInfo - context fields = Completions.getContext completerRecorder prefInfo fields - completerRecorder = cmapWithPrio LogCompletions recorder + where + pos = Types.completionCursorPosition prefInfo + context fields = Completions.getContext completerRecorder prefInfo fields + completerRecorder = cmapWithPrio LogCompletions recorder diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd.hs deleted file mode 100644 index 3b46eec128..0000000000 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd.hs +++ /dev/null @@ -1,326 +0,0 @@ -{-# 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 Data.Text.Utf16.Rope.Mixed as Rope -import Development.IDE (IdeState, - getFileContents, - useWithStale) -import Development.IDE.Core.Rules (runAction) -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 build targets, where this - -- module is mentioned (in exposed-modules or other-modules). - 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 "-" <> suggestedVersion - targetTitle = case target of - Nothing -> T.empty - Just t -> " at " <> 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." --- --- or this if PackageImports extension is used: --- --- > "Could not find module ‘Data.List.Split’ --- > Perhaps you meant --- > Data.List.Split (needs flag -package-id split-0.2.5)" --- --- 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 = - let regex' = "([a-zA-Z0-9-]*[a-zA-Z0-9])(-([0-9\\.]*))?" - in "It is a member of the hidden package [\8216']" <> regex' <> "[\8217']" - <> "|" - <> "needs flag -package-id " <> regex' - -- 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 (_, _, _, ["", "", "", dependency, _, cleanVersion]) = [(dependency, cleanVersion)] - getMatch (_, _, _, _) = [] - -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 <- getFileContents $ toNormalizedFilePath cabalFilePath - inFields <- useWithStale ParseCabalFields $ toNormalizedFilePath cabalFilePath - inPackDescr <- useWithStale ParseCabalFile $ toNormalizedFilePath cabalFilePath - let mbCnfOrigContents = case contents of - (Just txt) -> Just $ encodeUtf8 $ Rope.toText 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 a package.yaml is present in same directory as the .cabal file, returns nothing, because adding a dependency to a generated cabal file --- will break propagation of changes from package.yaml to cabal files in stack projects. --- 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 -> guardAgainstHpack path cabalFile - where - guardAgainstHpack :: FilePath -> FilePath -> IO (Maybe FilePath) - guardAgainstHpack path cabalFile = do - exists <- doesFileExist $ path "package.yaml" - if exists then pure Nothing else 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/CabalAdd/CodeAction.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/CodeAction.hs new file mode 100644 index 0000000000..993b382a82 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/CodeAction.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards #-} + +module Ide.Plugin.Cabal.CabalAdd.CodeAction where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Except +import Data.Aeson.Types (toJSON) +import Data.Foldable (asum) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, + mapMaybe) +import qualified Data.Text as T +import Development.IDE.Core.PluginUtils (uriToFilePathE) +import Development.IDE.Types.Location (Uri) +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import qualified Distribution.Pretty as CabalPretty +import Distribution.Simple.BuildTarget (BuildTarget, + buildTargetComponentName, + readBuildTargets) +import Distribution.Utils.Path (getSymbolicPath) +import Distribution.Verbosity (silent, + verboseNoStderr) +import Ide.Logger +import Ide.Plugin.Cabal.CabalAdd.Types +import Ide.Plugin.Cabal.Completion.Completer.Module (fpToExposedModulePath) +import Ide.Plugin.Cabal.Orphans () +import Ide.Plugin.Error +import Ide.PluginUtils (mkLspCommand) +import Ide.Types (CommandId (CommandId), + PluginId) + +import Control.Lens ((^.)) +import qualified Language.LSP.Protocol.Lens as JL +import Language.LSP.Protocol.Types (CodeActionKind (..), + VersionedTextDocumentIdentifier, + filePathToUri) +import qualified Language.LSP.Protocol.Types as J +import System.FilePath +import Text.PrettyPrint (render) +import Text.Regex.TDFA + +-------------------------------------------- +-- Add Module +-------------------------------------------- + +{- | Takes a path to a cabal file, a module path in exposed module syntax + and the contents of the cabal file and generates all possible + code actions for inserting the module into the cabal file + with the given contents. +-} +collectModuleInsertionOptions :: + (MonadIO m) => + Recorder (WithPriority Log) -> + PluginId -> + VersionedTextDocumentIdentifier -> + J.Diagnostic -> + -- | The file path of the cabal file to insert the new module into + FilePath -> + -- | The generic package description of the cabal file to insert the new module into. + GenericPackageDescription -> + -- | The URI of the unknown haskell file/new module to insert into the cabal file. + Uri -> + ExceptT PluginError m [J.CodeAction] +collectModuleInsertionOptions _ plId txtDocIdentifier diag cabalFilePath gpd haskellFilePathURI = do + haskellFilePath <- uriToFilePathE haskellFilePathURI + let configs = concatMap (mkModuleInsertionConfig txtDocIdentifier cabalFilePath haskellFilePath) (makeStanzaItems gpd) + pure $ map (mkCodeActionForModulePath plId diag) configs + where + makeStanzaItems :: GenericPackageDescription -> [StanzaItem] + makeStanzaItems gpd = + mainLibItem pd + ++ libItems pd + ++ executableItems pd + ++ testSuiteItems pd + ++ benchmarkItems pd + where + pd = flattenPackageDescription gpd + +{- | Takes a buildInfo of a cabal file component as defined in the generic package description, + and translates it to filepaths of the component's hsSourceDirs, + to be processed for adding modules to exposed-, or other-modules fields in a cabal file. +-} +buildInfoToHsSourceDirs :: BuildInfo -> [FilePath] +buildInfoToHsSourceDirs buildInfo = map getSymbolicPath hsSourceDirs' + where + hsSourceDirs' = hsSourceDirs buildInfo + +{- | Takes the path to the cabal file to insert the module into, + the module path to be inserted, and a stanza representation. + + Returns a list of module insertion configs, where each config + represents a possible place to insert the module. +-} +mkModuleInsertionConfig :: VersionedTextDocumentIdentifier -> FilePath -> FilePath -> StanzaItem -> [ModuleInsertionConfig] +mkModuleInsertionConfig txtDocIdentifier cabalFilePath haskellFilePath (StanzaItem{..}) = do + case mkRelativeModulePathM siHsSourceDirs cabalFilePath haskellFilePath of + Just processedModPath -> + [modInsertItem processedModPath "other-modules"] + ++ [modInsertItem processedModPath "exposed-modules" | CLibName _ <- [siComponent]] + _ -> [] + where + modInsertItem :: T.Text -> T.Text -> ModuleInsertionConfig + modInsertItem modPath label = + ModuleInsertionConfig + { targetFile = cabalFilePath + , moduleToInsert = modPath + , modVerTxtDocId = txtDocIdentifier + , insertionStanza = siComponent + , insertionLabel = label + } + +mkCodeActionForModulePath :: PluginId -> J.Diagnostic -> ModuleInsertionConfig -> J.CodeAction +mkCodeActionForModulePath plId diag insertionConfig = + J.CodeAction + { _title = "Add to " <> label <> " as " <> fieldDescription + , _kind = Just CodeActionKind_Refactor + , _diagnostics = Just [diag] + , _isPreferred = Nothing + , _disabled = Nothing + , _edit = Just workSpaceEdit + , _command = Just command + , _data_ = Nothing + } + where + fieldName = insertionLabel insertionConfig + command = mkLspCommand plId (CommandId cabalAddModuleCommandId) "Add missing module" (Just [toJSON insertionConfig]) + fieldDescription = fromMaybe fieldName $ T.stripSuffix "s:" fieldName + cabalFilePath = targetFile insertionConfig + label = T.pack $ CabalPretty.prettyShow $ insertionStanza insertionConfig + workSpaceEdit = + J.WorkspaceEdit + { J._changes = + Just $ + Map.singleton + (filePathToUri cabalFilePath) + [] -- makeDiffTextEdit on cabalAdd result + , J._documentChanges = Nothing + , J._changeAnnotations = Nothing + } + +{- | Takes a list of source subdirectories, a cabal source path and a haskell filepath + and returns a path to the module in exposed module syntax. + The path will be relative to one of the subdirectories, in case the module is contained within one of them. +-} +mkRelativeModulePathM :: [FilePath] -> FilePath -> FilePath -> Maybe T.Text +mkRelativeModulePathM hsSourceDirs cabalSrcPath' haskellFilePath = + asum $ + map + ( \srcDir -> do + let relMP = makeRelative (normalise (cabalSrcPath srcDir)) haskellFilePath + if relMP == haskellFilePath then Nothing else Just $ fpToExposedModulePath cabalSrcPath relMP + ) + hsSourceDirs + where + cabalSrcPath = takeDirectory cabalSrcPath' + +isUnknownModuleDiagnostic :: J.Diagnostic -> Bool +isUnknownModuleDiagnostic diag = (msg =~ regex) + where + msg :: T.Text + msg = diag ^. JL.message + regex :: T.Text + regex = "Loading the module [\8216'][^\8217']*[\8217'] failed." + +-------------------------- +-- Below are several utility functions which create a StanzaItem for each of the possible Stanzas, +-- these all have specific constructors we need to match, so we can't generalise this process well. +-------------------------- + +benchmarkItems :: PackageDescription -> [StanzaItem] +benchmarkItems pd = + map + ( \benchmark -> + StanzaItem + { siComponent = CBenchName $ benchmarkName benchmark + , siHsSourceDirs = buildInfoToHsSourceDirs $ benchmarkBuildInfo benchmark + } + ) + (benchmarks pd) + +testSuiteItems :: PackageDescription -> [StanzaItem] +testSuiteItems pd = + map + ( \testSuite -> + StanzaItem + { siComponent = CTestName $ testName testSuite + , siHsSourceDirs = buildInfoToHsSourceDirs $ testBuildInfo testSuite + } + ) + (testSuites pd) + +executableItems :: PackageDescription -> [StanzaItem] +executableItems pd = + map + ( \executable -> + StanzaItem + { siComponent = CExeName $ exeName executable + , siHsSourceDirs = buildInfoToHsSourceDirs $ buildInfo executable + } + ) + (executables pd) + +libItems :: PackageDescription -> [StanzaItem] +libItems pd = + mapMaybe + ( \subLib -> + case libName subLib of + LSubLibName compName -> + Just + StanzaItem + { siComponent = CLibName $ LSubLibName compName + , siHsSourceDirs = buildInfoToHsSourceDirs $ libBuildInfo subLib + } + _ -> Nothing + ) + (subLibraries pd) + +mainLibItem :: PackageDescription -> [StanzaItem] +mainLibItem pd = + case library pd of + Just lib -> + [ StanzaItem + { siComponent = CLibName LMainLibName + , siHsSourceDirs = buildInfoToHsSourceDirs $ libBuildInfo lib + } + ] + Nothing -> [] + +-------------------------------------------- +-- Add Package +-------------------------------------------- + +{- | 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 and cabal file paths to create a relative path + to the haskell file, which is used to get a `BuildTarget`. +-} +addDependencySuggestCodeAction :: + PluginId -> + -- | Cabal's versioned text identifier + VersionedTextDocumentIdentifier -> + -- | A dependency-version suggestion pairs + [(T.Text, T.Text)] -> + -- | Path to the haskell file (source of diagnostics) + FilePath -> + -- | Path to the cabal file (that will be edited) + FilePath -> + GenericPackageDescription -> + IO [J.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 the `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 the `pretty` function. + It converts the `BuildTarget` to an acceptable string representation. + It will be used as the input for `cabal-add`'s `executeConfig`. + -} + buildTargetToStringRepr target = render $ CabalPretty.pretty $ buildTargetComponentName target + + {- | Finds the build targets that are used in `cabal-add`. + Note the unorthodox usage of `readBuildTargets`: + If the relative path to the haskell file is provided, + `readBuildTargets` will return the build targets, this + module is mentioned in (either exposed-modules or other-modules). + -} + 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) -> J.CodeAction + mkCodeAction cabalFilePath target (suggestedDep, suggestedVersion) = + let + versionTitle = if T.null suggestedVersion then T.empty else "-" <> suggestedVersion + targetTitle = case target of + Nothing -> T.empty + Just t -> " at " <> T.pack t + title = "Add dependency " <> suggestedDep <> versionTitle <> targetTitle + version = if T.null suggestedVersion then Nothing else Just suggestedVersion + + params = + CabalAddPackageCommandParams + { pkgCabalPath = cabalFilePath + , pkgVerTxtDocId = verTxtDocId + , pkgBuildTarget = target + , pkgDependency = suggestedDep + , pkgVersion = version + } + command = mkLspCommand plId (CommandId cabalAddPackageCommandId) "Add dependency" (Just [toJSON params]) + in + J.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." + +or this if PackageImports extension is used: + +> "Could not find module ‘Data.List.Split’ +> Perhaps you meant +> Data.List.Split (needs flag -package-id split-0.2.5)" + +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 :: J.Diagnostic -> [(T.Text, T.Text)] +hiddenPackageSuggestion diag = getMatch (msg =~ regex) + where + msg :: T.Text + msg = diag ^. JL.message + regex :: T.Text + regex = + let regex' = "([a-zA-Z0-9-]*[a-zA-Z0-9])(-([0-9\\.]*))?" + in "It is a member of the hidden package [\8216']" + <> regex' + <> "[\8217']" + <> "|" + <> "needs flag -package-id " + <> regex' + -- 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 (_, _, _, ["", "", "", dependency, _, cleanVersion]) = [(dependency, cleanVersion)] + getMatch (_, _, _, _) = [] diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/Command.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/Command.hs new file mode 100644 index 0000000000..0039dee6d9 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/Command.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards #-} + +module Ide.Plugin.Cabal.CabalAdd.Command ( + cabalAddPackageCommandId, + cabalAddModuleCommandId, + addPackageCommand, + addModuleCommand, + Log, +) +where + +import Control.Monad (void) +import Control.Monad.Except (modifyError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.List.NonEmpty (singleton) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Encoding as T +import Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE.Core.FileStore (getFileContents) +import Development.IDE.Core.Rules (IdeState) +import Development.IDE.Core.Service (runAction) +import Development.IDE.Core.Shake (useWithStale) +import Distribution.Client.Add as Add +import Distribution.Fields (Field) +import Distribution.PackageDescription +import Distribution.Parsec.Position (Position) +import qualified Distribution.Pretty as CabalPretty +import Ide.Logger +import Ide.Plugin.Cabal.CabalAdd.Types +import Ide.Plugin.Cabal.Completion.Types (ParseCabalFields (..), + ParseCabalFile (..)) +import Ide.Plugin.Cabal.Files +import Ide.Plugin.Cabal.Orphans () +import Ide.Plugin.Error +import Ide.PluginUtils (WithDeletions (SkipDeletions), + diffText) +import Ide.Types (CommandFunction, + pluginGetClientCapabilities, + pluginSendRequest) +import Language.LSP.Protocol.Message (SMethod (SMethod_WorkspaceApplyEdit)) +import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), + ClientCapabilities, + Null (Null), + VersionedTextDocumentIdentifier, + WorkspaceEdit, + toNormalizedFilePath, + type (|?) (InR)) + +-------------------------------------------- +-- Add Module +-------------------------------------------- + +addModuleCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState ModuleInsertionConfig +addModuleCommand recorder state _ params@(ModuleInsertionConfig{..}) = do + logWith recorder Debug $ LogCalledCabalAddModuleCommand params + caps <- lift pluginGetClientCapabilities + let env = (state, caps, modVerTxtDocId) + edit <- getModuleEdit recorder env targetFile insertionStanza (T.unpack insertionLabel) (T.unpack moduleToInsert) + 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 +-} +getModuleEdit :: + forall m. + (MonadIO m) => + Recorder (WithPriority Log) -> + (IdeState, ClientCapabilities, VersionedTextDocumentIdentifier) -> + -- | The cabal file to edit. + FilePath -> + -- | The component to add the module to. + ComponentName -> + -- | The specific field in the component to add the module to. + String -> + -- | The module to add. + String -> + ExceptT PluginError m WorkspaceEdit +getModuleEdit recorder env cabalFilePath stanza targetFieldStr modulePath = + mkCabalAddConfig + recorder + env + cabalFilePath + mkConfig + where + mkConfig :: (ByteString -> [Field Position] -> GenericPackageDescription -> ExceptT PluginError m AddConfig) + mkConfig cnfOrigContents fields packDescr = do + let compName = + case Add.resolveComponent cabalFilePath (fields, packDescr) $ Just $ CabalPretty.prettyShow stanza of + Right x -> x + Left _ -> error "" + pure $ + AddConfig + { cnfOrigContents = cnfOrigContents + , cnfFields = fields + , cnfComponent = compName + , cnfTargetField = if targetFieldStr == "exposed-modules" then ExposedModules else OtherModules + , cnfAdditions = singleton $ B.pack modulePath + } + +-------------------------------------------- +-- Add Package +-------------------------------------------- + +addPackageCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState CabalAddPackageCommandParams +addPackageCommand recorder state _ params@(CabalAddPackageCommandParams{..}) = do + logWith recorder Debug $ LogCalledCabalAddPackageCommand params + let specifiedDep = case pkgVersion of + Nothing -> pkgDependency + Just ver -> pkgDependency <> " ^>=" <> ver + caps <- lift pluginGetClientCapabilities + let env = (state, caps, pkgVerTxtDocId) + edit <- getDependencyEdit recorder env pkgCabalPath pkgBuildTarget (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 :: + forall m. + (MonadIO m) => + Recorder (WithPriority Log) -> + (IdeState, ClientCapabilities, VersionedTextDocumentIdentifier) -> + FilePath -> + Maybe String -> + String -> + ExceptT PluginError m WorkspaceEdit +getDependencyEdit recorder env cabalFilePath buildTarget dependency = + mkCabalAddConfig recorder env cabalFilePath mkConfig + where + mkConfig :: (ByteString -> [Field Position] -> GenericPackageDescription -> ExceptT PluginError m AddConfig) + mkConfig cnfOrigContents fields packDescr = do + let specVer = specVersion $ packageDescription packDescr + (deps, compName) <- + modifyError (\t -> PluginInternalError $ T.pack t) $ do + deps <- validateDependency specVer dependency + compName <- resolveComponent cabalFilePath (fields, packDescr) buildTarget + pure (deps, compName) + pure $ + AddConfig + { cnfOrigContents = cnfOrigContents + , cnfFields = fields + , cnfComponent = compName + , cnfTargetField = BuildDepends + , cnfAdditions = singleton deps + } + +-------------------------------------------- +-- Shared Functions +-------------------------------------------- + +mkCabalAddConfig :: + (MonadIO m) => + Recorder (WithPriority Log) -> + (IdeState, ClientCapabilities, VersionedTextDocumentIdentifier) -> + -- | The cabal file to edit + FilePath -> + -- | Function to generate a config to be used by cabal-add + ( ByteString -> + [Field Position] -> + GenericPackageDescription -> + ExceptT PluginError m AddConfig + ) -> + ExceptT PluginError m WorkspaceEdit +mkCabalAddConfig recorder env cabalFilePath mkConfig = do + let (state, caps, verTxtDocId) = env + (mbCnfOrigContents, mbFields, mbPackDescr) <- liftIO $ runAction "cabal.cabal-add" state $ do + contents <- getFileContents $ toNormalizedFilePath cabalFilePath + inFields <- useWithStale ParseCabalFields $ toNormalizedFilePath cabalFilePath + inPackDescr <- useWithStale ParseCabalFile $ toNormalizedFilePath cabalFilePath + let mbCnfOrigContents = case contents of + (Just txt) -> Just $ encodeUtf8 $ Rope.toText 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) + + cabalAddConfig <- mkConfig cnfOrigContents fields packDescr + + case executeAddConfig (validateChanges packDescr) cabalAddConfig of + Nothing -> + throwE $ + PluginInternalError $ + T.pack $ + "Cannot extend " + ++ show (cnfTargetField cabalAddConfig) + ++ " of " + ++ case (cnfComponent cabalAddConfig) of + Right compName -> showComponentName compName + Left commonStanza -> show commonStanza + ++ " in " + ++ cabalFilePath + Just newContents -> do + let edit = diffText caps (verTxtDocId, T.decodeUtf8 cnfOrigContents) (T.decodeUtf8 newContents) SkipDeletions + logWith recorder Debug $ LogCreatedEdit edit + pure edit diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/Types.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/Types.hs new file mode 100644 index 0000000000..ead6d67e81 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/Types.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards #-} + +module Ide.Plugin.Cabal.CabalAdd.Types where + +import Data.Aeson.Types (FromJSON, ToJSON) +import Data.String (IsString) +import qualified Data.Text as T +import Distribution.Compat.Prelude (Generic) +import Distribution.PackageDescription +import Ide.Logger +import Ide.Plugin.Cabal.Orphans () +import Language.LSP.Protocol.Types + +data Log + = LogCalledCabalAddPackageCommand CabalAddPackageCommandParams + | LogCalledCabalAddModuleCommand ModuleInsertionConfig + | LogCreatedEdit WorkspaceEdit + | LogExecutedCommand + deriving (Show) + +instance Pretty Log where + pretty = \case + LogCalledCabalAddPackageCommand params -> "Called CabalAddPackage command with:\n" <+> pretty params + LogCalledCabalAddModuleCommand params -> "Called CabalAddModule command with:\n" <+> pretty params + LogCreatedEdit edit -> "Created inplace edit:\n" <+> pretty edit + LogExecutedCommand -> "Executed CabalAdd command" + +cabalAddPackageCommandId :: (IsString p) => p +cabalAddPackageCommandId = "cabalAddPackage" + +cabalAddModuleCommandId :: (IsString p) => p +cabalAddModuleCommandId = "cabalAddModule" + +-- | Relevant data needed to add a module to a cabal file. +data ModuleInsertionConfig = ModuleInsertionConfig + { targetFile :: FilePath + -- ^ The file we want to insert information about the new module into. + , moduleToInsert :: T.Text + -- ^ The module name of the module to be inserted into the targetFile at the insertionPosition. + , modVerTxtDocId :: VersionedTextDocumentIdentifier + , insertionStanza :: ComponentName + -- ^ Which stanza the module will be inserted into. + , insertionLabel :: T.Text + -- ^ A label which describes which field the module will be inserted into. + } + deriving (Show, Eq, Ord, Generic) + deriving anyclass (FromJSON, ToJSON) + +instance Pretty ModuleInsertionConfig where + pretty ModuleInsertionConfig{..} = + "CabalAdd parameters:" + <+> vcat + [ "cabal path:" <+> pretty targetFile + , "target:" <+> pretty moduleToInsert + , "stanza:" <+> viaShow insertionStanza + , "label:" <+> pretty insertionLabel + ] + +-- | Contains all source directories of a stanza with the name of the first parameter. +data StanzaItem = StanzaItem + { siComponent :: ComponentName + , siHsSourceDirs :: [FilePath] + } + deriving (Show) + +-- | Parameters for the LSP `CabalAddCommand` +data CabalAddPackageCommandParams = CabalAddPackageCommandParams + { pkgCabalPath :: FilePath + , pkgVerTxtDocId :: VersionedTextDocumentIdentifier + , pkgBuildTarget :: Maybe String + , pkgDependency :: T.Text + , pkgVersion :: Maybe T.Text + } + deriving (Generic, Show) + deriving anyclass (FromJSON, ToJSON) + +instance Pretty CabalAddPackageCommandParams where + pretty CabalAddPackageCommandParams{..} = + "CabalAdd parameters:" + <+> vcat + [ "cabal path:" <+> pretty pkgCabalPath + , "target:" <+> pretty pkgBuildTarget + , "dependendency:" <+> pretty pkgDependency + , "version:" <+> pretty pkgVersion + ] diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Files.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Files.hs new file mode 100644 index 0000000000..28cf1e39a8 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Files.hs @@ -0,0 +1,56 @@ +module Ide.Plugin.Cabal.Files where + +import Control.Monad (filterM) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Except +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.Text as T +import Distribution.PackageDescription.Quirks (patchQuirks) +import Distribution.Simple.Utils (safeHead) +import Ide.Plugin.Cabal.Orphans () +import Ide.Plugin.Error +import System.Directory (doesFileExist, + listDirectory) +import System.FilePath + +{- | Given a path to a haskell file, returns the closest cabal file. + If a package.yaml is present in same directory as the .cabal file, returns nothing, + because adding a dependency to a generated cabal file will break propagation of changes + from package.yaml to cabal files in stack projects. + If cabal file wasn't found, returns 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 -> guardAgainstHpack path cabalFile + where + guardAgainstHpack :: FilePath -> FilePath -> IO (Maybe FilePath) + guardAgainstHpack path cabalFile = do + exists <- doesFileExist $ path "package.yaml" + if exists then pure Nothing else pure $ Just cabalFile + +{- | Gives a 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/OfInterest.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/OfInterest.hs new file mode 100644 index 0000000000..6b264d989b --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/OfInterest.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.Cabal.OfInterest (ofInterestRules, getCabalFilesOfInterestUntracked, addFileOfInterest, deleteFileOfInterest, kick, Log) where + +import Control.Concurrent.Strict +import Control.DeepSeq +import Control.Monad.IO.Class +import qualified Data.ByteString as BS +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Proxy +import qualified Data.Text () +import Development.IDE as D +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Graph (Key, alwaysRerun) +import Development.IDE.Types.Shake (toKey) +import GHC.Generics +import qualified Ide.Plugin.Cabal.Completion.Types as Types +import Ide.Plugin.Cabal.Orphans () + +data Log + = LogShake Shake.Log + | LogFOI (HashMap NormalizedFilePath FileOfInterestStatus) + deriving (Show) + +instance Pretty Log where + pretty = \case + LogShake log' -> pretty log' + LogFOI files -> + "Set files of interest to:" <+> viaShow files + +-- ---------------------------------------------------------------- +-- Cabal file of Interest rules and global variable +-- ---------------------------------------------------------------- + +{- | Cabal files that are currently open in the lsp-client. +Specific actions happen when these files are saved, closed or modified, +such as generating diagnostics, re-parsing, etc... + +We need to store the open files to parse them again if we restart the shake session. +Restarting of the shake session happens whenever these files are modified. +-} +newtype OfInterestCabalVar = OfInterestCabalVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) + +instance Shake.IsIdeGlobal OfInterestCabalVar + +data IsCabalFileOfInterest = IsCabalFileOfInterest + deriving (Eq, Show, Generic) +instance Hashable IsCabalFileOfInterest +instance NFData IsCabalFileOfInterest + +type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult + +data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus + deriving (Eq, Show, Generic) +instance Hashable CabalFileOfInterestResult +instance NFData CabalFileOfInterestResult + +{- | The rule that initialises the files of interest state. + +Needs to be run on start-up. +-} +ofInterestRules :: Recorder (WithPriority Log) -> Rules () +ofInterestRules recorder = do + Shake.addIdeGlobal . OfInterestCabalVar =<< liftIO (newVar HashMap.empty) + Shake.defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsCabalFileOfInterest f -> do + alwaysRerun + filesOfInterest <- getCabalFilesOfInterestUntracked + let foi = maybe NotCabalFOI IsCabalFOI $ f `HashMap.lookup` filesOfInterest + fp = summarize foi + res = (Just fp, Just foi) + return res + where + summarize NotCabalFOI = BS.singleton 0 + summarize (IsCabalFOI OnDisk) = BS.singleton 1 + summarize (IsCabalFOI (Modified False)) = BS.singleton 2 + summarize (IsCabalFOI (Modified True)) = BS.singleton 3 + +getCabalFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus) +getCabalFilesOfInterestUntracked = do + OfInterestCabalVar var <- Shake.getIdeGlobalAction + liftIO $ readVar var + +addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key] +addFileOfInterest recorder state f v = do + OfInterestCabalVar var <- Shake.getIdeGlobalState state + (prev, files) <- modifyVar var $ \dict -> do + let (prev, new) = HashMap.alterF (,Just v) f dict + pure (new, (prev, new)) + if prev /= Just v + then do + log' Debug $ LogFOI files + return [toKey IsCabalFileOfInterest f] + else return [] + where + log' = logWith recorder + +deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO [Key] +deleteFileOfInterest recorder state f = do + OfInterestCabalVar var <- Shake.getIdeGlobalState state + files <- modifyVar' var $ HashMap.delete f + log' Debug $ LogFOI files + return [toKey IsFileOfInterest f] + where + log' = logWith recorder + +{- | This is the kick function for the cabal plugin. +We run this action, whenever we shake session us run/restarted, which triggers +actions to produce diagnostics for cabal files. + +It is paramount that this kick-function can be run quickly, since it is a blocking +function invocation. +-} +kick :: Action () +kick = do + files <- HashMap.keys <$> getCabalFilesOfInterestUntracked + Shake.runWithSignal (Proxy @"kick/start/cabal") (Proxy @"kick/done/cabal") files Types.ParseCabalFile diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Orphans.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Orphans.hs index 2264d5390f..8ecb361025 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Orphans.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Orphans.hs @@ -1,8 +1,14 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Ide.Plugin.Cabal.Orphans where import Control.DeepSeq +import Data.Aeson +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.Text as T import Distribution.Fields.Field -import Distribution.Parsec.Position +import Distribution.PackageDescription (ComponentName) +import Distribution.Parsec +import Distribution.Pretty (prettyShow) -- ---------------------------------------------------------------- -- Cabal-syntax orphan instances we need sometimes @@ -22,3 +28,12 @@ instance NFData (SectionArg Position) where rnf (SecArgName ann bs) = rnf ann `seq` rnf bs rnf (SecArgStr ann bs) = rnf ann `seq` rnf bs rnf (SecArgOther ann bs) = rnf ann `seq` rnf bs + +instance ToJSON ComponentName where + toJSON = Aeson.String . T.pack . prettyShow + +instance FromJSON ComponentName where + parseJSON = Aeson.withText "ComponentName" $ \t -> + case eitherParsec (T.unpack t) of + Left err -> Aeson.parseFail err + Right r -> pure r diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs index e949af1b1d..f2b3d74639 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs @@ -22,9 +22,9 @@ import qualified Distribution.Parsec.Position as Syntax parseCabalFileContents :: BS.ByteString -- ^ UTF-8 encoded bytestring - -> IO ([PWarning], Either (Maybe Version, NonEmpty PError) GenericPackageDescription) + -> ([PWarning], Either (Maybe Version, NonEmpty PError) GenericPackageDescription) parseCabalFileContents bs = - pure $ runParseResult (parseGenericPackageDescription bs) + runParseResult (parseGenericPackageDescription bs) readCabalFields :: NormalizedFilePath -> diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Rules.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Rules.hs new file mode 100644 index 0000000000..dedf5a4ba4 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Rules.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.Cabal.Rules (cabalRules, Log) where + +import Control.Monad.IO.Class +import qualified Data.ByteString as BS +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE +import qualified Data.Maybe as Maybe +import qualified Data.Text () +import qualified Data.Text as T +import qualified Data.Text.Encoding as Encoding +import Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE as D +import qualified Development.IDE.Core.Shake as Shake +import qualified Distribution.CabalSpecVersion as Cabal +import qualified Distribution.Fields as Syntax +import Distribution.Parsec.Error +import qualified Ide.Plugin.Cabal.Completion.Data as Data +import Ide.Plugin.Cabal.Completion.Types (ParseCabalCommonSections (ParseCabalCommonSections), + ParseCabalFields (..), + ParseCabalFile (..)) +import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics +import qualified Ide.Plugin.Cabal.OfInterest as OfInterest +import Ide.Plugin.Cabal.Orphans () +import qualified Ide.Plugin.Cabal.Parse as Parse +import Ide.Types +import Text.Regex.TDFA + +data Log + = LogModificationTime NormalizedFilePath FileVersion + | LogShake Shake.Log + | LogOfInterest OfInterest.Log + deriving (Show) + +instance Pretty Log where + pretty = \case + LogShake log' -> pretty log' + LogOfInterest log' -> pretty log' + LogModificationTime nfp modTime -> + "Modified:" <+> pretty (fromNormalizedFilePath nfp) <+> pretty (show modTime) + +cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules () +cabalRules recorder plId = do + -- Make sure we initialise the cabal files-of-interest. + OfInterest.ofInterestRules (cmapWithPrio LogOfInterest recorder) + -- Rule to produce diagnostics for cabal files. + define (cmapWithPrio LogShake recorder) $ \ParseCabalFields file -> do + config <- getPluginConfigAction plId + if not (plcGlobalOn config && plcDiagnosticsOn config) + then pure ([], Nothing) + else do + -- whenever this key is marked as dirty (e.g., when a user writes stuff to it), + -- we rerun this rule because this rule *depends* on GetModificationTime. + (t, mCabalSource) <- use_ GetFileContents file + log' Debug $ LogModificationTime file t + contents <- case mCabalSource of + Just sources -> + pure $ Encoding.encodeUtf8 $ Rope.toText sources + Nothing -> do + liftIO $ BS.readFile $ fromNormalizedFilePath file + + case Parse.readCabalFields file contents of + Left _ -> + pure ([], Nothing) + Right fields -> + pure ([], Just fields) + + define (cmapWithPrio LogShake recorder) $ \ParseCabalCommonSections file -> do + fields <- use_ ParseCabalFields file + let commonSections = + Maybe.mapMaybe + ( \case + commonSection@(Syntax.Section (Syntax.Name _ "common") _ _) -> Just commonSection + _ -> Nothing + ) + fields + pure ([], Just commonSections) + + define (cmapWithPrio LogShake recorder) $ \ParseCabalFile file -> do + config <- getPluginConfigAction plId + if not (plcGlobalOn config && plcDiagnosticsOn config) + then pure ([], Nothing) + else do + -- whenever this key is marked as dirty (e.g., when a user writes stuff to it), + -- we rerun this rule because this rule *depends* on GetModificationTime. + (t, mCabalSource) <- use_ GetFileContents file + log' Debug $ LogModificationTime file t + contents <- case mCabalSource of + Just sources -> + pure $ Encoding.encodeUtf8 $ Rope.toText sources + Nothing -> do + liftIO $ BS.readFile $ fromNormalizedFilePath file + + -- Instead of fully reparsing the sources to get a 'GenericPackageDescription', + -- we would much rather re-use the already parsed results of 'ParseCabalFields'. + -- Unfortunately, Cabal-syntax doesn't expose the function 'parseGenericPackageDescription'' + -- which allows us to resume the parsing pipeline with '[Field Position]'. + let (pWarnings, pm) = Parse.parseCabalFileContents contents + let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings + case pm of + Left (_cabalVersion, pErrorNE) -> do + let regexUnknownCabalBefore310 :: T.Text + -- We don't support the cabal version, this should not be an error, as the + -- user did not do anything wrong. Instead we cast it to a warning + regexUnknownCabalBefore310 = "Unsupported cabal-version [0-9]+.[0-9]*" + regexUnknownCabalVersion :: T.Text + regexUnknownCabalVersion = "Unsupported cabal format version in cabal-version field: [0-9]+.[0-9]+" + unsupportedCabalHelpText = + unlines + [ "The used `cabal-version` is not fully supported by this `HLS` binary." + , "Either the `cabal-version` is unknown, or too new for this executable." + , "This means that some functionality might not work as expected." + , "If you face any issues, try downgrading to a supported `cabal-version` or upgrading `HLS` if possible." + , "" + , "Supported versions are: " + <> List.intercalate + ", " + (fmap Cabal.showCabalSpecVersion Data.supportedCabalVersions) + ] + errorDiags = + NE.toList $ + NE.map + ( \pe@(PError pos text) -> + if any + (text =~) + [ regexUnknownCabalBefore310 + , regexUnknownCabalVersion + ] + then + Diagnostics.warningDiagnostic + file + ( Syntax.PWarning Syntax.PWTOther pos $ + unlines + [ text + , unsupportedCabalHelpText + ] + ) + else Diagnostics.errorDiagnostic file pe + ) + pErrorNE + allDiags = errorDiags <> warningDiags + pure (allDiags, Nothing) + Right gpd -> do + pure (warningDiags, Just gpd) + + action $ do + -- Run the cabal kick. This code always runs when 'shakeRestart' is run. + -- Must be careful to not impede the performance too much. Crucial to + -- a snappy IDE experience. + OfInterest.kick + where + log' = logWith recorder diff --git a/plugins/hls-cabal-plugin/test/CabalAdd.hs b/plugins/hls-cabal-plugin/test/CabalAdd.hs index 6517c811fe..60c0d6200a 100644 --- a/plugins/hls-cabal-plugin/test/CabalAdd.hs +++ b/plugins/hls-cabal-plugin/test/CabalAdd.hs @@ -1,32 +1,102 @@ {-# LANGUAGE OverloadedStrings #-} module CabalAdd ( - cabalAddTests, + cabalAddDependencyTests, + cabalAddModuleTests, ) 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 Control.Lens ((^.)) +import Control.Lens.Fold ((^?)) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Internal.Search as T +import Distribution.ModuleName (fromString) +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import qualified Distribution.Pretty as Pretty +import Distribution.Types.Component +import Distribution.Utils.Generic (safeHead) +import Ide.Plugin.Cabal.CabalAdd.CodeAction (hiddenPackageSuggestion) +import Ide.Plugin.Cabal.Parse (parseCabalFileContents) +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, - getAllCodeActions, - getDocumentEdit, liftIO, openDoc, - skipManyTill, testCase, testGroup, - waitForDiagnosticsFrom, (@?=)) +import Test.Hls (Session, + TestTree, _R, + anyMessage, + assertBool, + assertEqual, + assertFailure, + documentContents, + executeCodeAction, + getAllCodeActions, + getDocumentEdit, + liftIO, openDoc, + skipManyTill, + testCase, + testGroup, + waitForDiagnosticsFrom, + (@?=)) import Utils -cabalAddTests :: TestTree -cabalAddTests = +cabalAddModuleTests :: TestTree +cabalAddModuleTests = + testGroup + "Add Module" + [ runHaskellTestCaseSession "Code Actions - Can add module to benchmark" ("cabal-add-module" "library") $ do + let compName = CBenchName "test1" + pd <- generateAddDependencyTestSession "test.cabal" "Main.hs" compName + checkModuleAddedTo pd "Main" $ compName + , runHaskellTestCaseSession "Code Actions - Can add module to executable" ("cabal-add-module" "library") $ do + let compName = CExeName "test" + pd <- generateAddDependencyTestSession "test.cabal" "Main.hs" compName + checkModuleAddedTo pd "Main" $ compName + , runHaskellTestCaseSession "Code Actions - Can add module to test-suite" ("cabal-add-module" "library") $ do + let compName = CTestName "test2" + pd <- generateAddDependencyTestSession "test.cabal" "Main.hs" compName + checkModuleAddedTo pd "Main" $ compName + , runHaskellTestCaseSession "Code Actions - Can add module to library" ("cabal-add-module" "library") $ do + let compName = CLibName $ LSubLibName "test3" + pd <- generateAddDependencyTestSession "test.cabal" "Main.hs" compName + checkModuleAddedTo pd "Main" $ compName + , runHaskellTestCaseSession "Code Actions - Can add module to main library" ("cabal-add-module" "library") $ do + let compName = CLibName LMainLibName + pd <- generateAddDependencyTestSession "test.cabal" "Main.hs" compName + checkModuleAddedTo pd "Main" $ compName + ] + where + generateAddDependencyTestSession :: FilePath -> FilePath -> ComponentName -> Session PackageDescription + generateAddDependencyTestSession cabalFile haskellFile compName = do + haskellDoc <- openDoc haskellFile "haskell" + cabalDoc <- openDoc cabalFile "cabal" + _ <- waitForDiagnosticsFrom haskellDoc + cas <- Maybe.mapMaybe (^? _R) <$> getAllCodeActions haskellDoc + let selectedCas = filter (\ca -> (T.pack $ "Add to " <> (Pretty.prettyShow compName)) `T.isPrefixOf` (ca ^. L.title)) cas + mapM_ executeCodeAction $ selectedCas + _ <- skipManyTill anyMessage $ getDocumentEdit cabalDoc -- Wait for the changes in cabal file + contents <- documentContents cabalDoc + case parseCabalFileContents $ T.encodeUtf8 contents of + (_, Right gpd) -> pure $ flattenPackageDescription gpd + _ -> liftIO $ assertFailure "could not parse cabal file to gpd" + + checkModuleAddedTo :: PackageDescription -> String -> ComponentName -> Session () + checkModuleAddedTo pd modName compName = do + let comp = getComponent pd compName + compModules = case comp of + CLib lib -> explicitLibModules lib + CFLib fLib -> foreignLibModules fLib + CExe exe -> exeModules exe + CTest test -> testModules test + CBench bench -> benchmarkModules bench + testDescription = (modName <> " was added to " <> (showComponentName compName)) + liftIO $ assertBool testDescription $ (fromString modName) `elem` compModules + +cabalAddDependencyTests :: TestTree +cabalAddDependencyTests = testGroup - "CabalAdd Tests" + "Add Package" [ runHaskellTestCaseSession "Code Actions - Can add hidden package to an executable" ("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") @@ -156,7 +226,7 @@ cabalAddTests = 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 + 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 @@ -175,9 +245,8 @@ cabalAddTests = , _data_ = Nothing } - generatePackageYAMLTestSession :: FilePath -> Session () - generatePackageYAMLTestSession haskellFile = do + generatePackageYAMLTestSession haskellFile = do hsdoc <- openDoc haskellFile "haskell" _ <- waitForDiagnosticsFrom hsdoc cas <- Maybe.mapMaybe (^? _R) <$> getAllCodeActions hsdoc diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index fcb85a081e..0ae2134162 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -6,7 +6,8 @@ module Main ( main, ) where -import CabalAdd (cabalAddTests) +import CabalAdd (cabalAddDependencyTests, + cabalAddModuleTests) import Completer (completerTests) import Context (contextTests) import Control.Lens ((^.)) @@ -58,7 +59,8 @@ cabalParserUnitTests = testGroup "Parsing Cabal" [ testCase "Simple Parsing works" $ do - (warnings, pm) <- Lib.parseCabalFileContents =<< BS.readFile (testDataDir "simple.cabal") + fileContents <- BS.readFile (testDataDir "simple.cabal") + let (warnings, pm) = Lib.parseCabalFileContents $ fileContents liftIO $ do null warnings @? "Found unexpected warnings" isRight pm @? "Failed to parse GenericPackageDescription" @@ -208,7 +210,8 @@ codeActionTests = testGroup "Code Actions" ]) cas mapM_ executeCodeAction selectedCas pure () - , cabalAddTests + , cabalAddDependencyTests + , cabalAddModuleTests ] where getLicenseAction :: T.Text -> [Command |? CodeAction] -> [CodeAction] diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/Main.hs b/plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/Main.hs new file mode 100644 index 0000000000..c2e4af9606 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = undefined diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/cabal.project b/plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/cabal.project new file mode 100644 index 0000000000..5356e76f67 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/cabal.project @@ -0,0 +1 @@ +packages: . \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/hie.yaml b/plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/hie.yaml new file mode 100644 index 0000000000..f0c7014d7f --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/test.cabal b/plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/test.cabal new file mode 100644 index 0000000000..966a431580 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/test.cabal @@ -0,0 +1,27 @@ +cabal-version: 3.0 +name: test +version: 0.1.0.0 +build-type: Simple + +library + hs-source-dirs: . + exposed-modules: + build-depends: base + default-language: Haskell2010 + +executable test + main-is: bla + build-depends: base + +benchmark test1 + type: exitcode-stdio-1.0 + main-is: bla + build-depends: base + +test-suite test2 + type: exitcode-stdio-1.0 + main-is: bla + build-depends: base + +library test3 + \ No newline at end of file