Skip to content

Commit 4d309d5

Browse files
VeryMilkyJoefendor
VeryMilkyJoe
authored and
fendor
committed
Add Code Action for adding a module to the cabal file
For diagnostics complaining about the current module being unknown, we now offer code actions to add the module to any possible field in the responsible cabal file. Additionally, refactor the cabal-plugin into smaller modules and refactor the add-package feature to have some shared functions to be used for both add-package and add-module.
1 parent cfeced8 commit 4d309d5

File tree

19 files changed

+1347
-715
lines changed

19 files changed

+1347
-715
lines changed

‎haskell-language-server.cabal

Lines changed: 8 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -254,8 +254,13 @@ library hls-cabal-plugin
254254
Ide.Plugin.Cabal.Completion.Types
255255
Ide.Plugin.Cabal.Definition
256256
Ide.Plugin.Cabal.FieldSuggest
257+
Ide.Plugin.Cabal.Files
258+
Ide.Plugin.Cabal.OfInterest
257259
Ide.Plugin.Cabal.LicenseSuggest
258-
Ide.Plugin.Cabal.CabalAdd
260+
Ide.Plugin.Cabal.Rules
261+
Ide.Plugin.Cabal.CabalAdd.Command
262+
Ide.Plugin.Cabal.CabalAdd.CodeAction
263+
Ide.Plugin.Cabal.CabalAdd.Types
259264
Ide.Plugin.Cabal.Orphans
260265
Ide.Plugin.Cabal.Outline
261266
Ide.Plugin.Cabal.Parse
@@ -276,14 +281,14 @@ library hls-cabal-plugin
276281
, lens
277282
, lsp ^>=2.7
278283
, lsp-types ^>=2.3
284+
, mtl
279285
, regex-tdfa ^>=1.3.1
280286
, text
281287
, text-rope
282288
, transformers
283289
, unordered-containers >=0.2.10.0
284290
, containers
285-
, cabal-add ^>=0.1
286-
, process
291+
, cabal-add ^>=0.2
287292
, aeson
288293
, Cabal
289294
, pretty
@@ -315,7 +320,6 @@ test-suite hls-cabal-plugin-tests
315320
, lens
316321
, lsp-types
317322
, text
318-
, hls-plugin-api
319323

320324
-----------------------------
321325
-- class plugin

‎plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs

Lines changed: 162 additions & 327 deletions
Large diffs are not rendered by default.

‎plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd.hs

Lines changed: 0 additions & 326 deletions
This file was deleted.

‎plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/CodeAction.hs

Lines changed: 343 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,343 @@
1+
{-# LANGUAGE AllowAmbiguousTypes #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
3+
{-# LANGUAGE DerivingStrategies #-}
4+
{-# LANGUAGE ExplicitNamespaces #-}
5+
{-# LANGUAGE LambdaCase #-}
6+
{-# LANGUAGE OverloadedStrings #-}
7+
{-# LANGUAGE PartialTypeSignatures #-}
8+
{-# LANGUAGE RecordWildCards #-}
9+
10+
module Ide.Plugin.Cabal.CabalAdd.CodeAction where
11+
12+
import Control.Monad.IO.Class (MonadIO, liftIO)
13+
import Control.Monad.Trans.Except
14+
import Data.Aeson.Types (toJSON)
15+
import Data.Foldable (asum)
16+
import Data.Maybe (mapMaybe)
17+
import qualified Data.Text as T
18+
import Development.IDE.Core.PluginUtils (uriToFilePathE)
19+
import Development.IDE.Types.Location (Uri)
20+
import Distribution.PackageDescription
21+
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
22+
import qualified Distribution.Pretty as CabalPretty
23+
import Distribution.Simple.BuildTarget (BuildTarget,
24+
buildTargetComponentName,
25+
readBuildTargets)
26+
import Distribution.Utils.Path (getSymbolicPath)
27+
import Distribution.Verbosity (silent,
28+
verboseNoStderr)
29+
import Ide.Logger
30+
import Ide.Plugin.Cabal.CabalAdd.Types
31+
import Ide.Plugin.Cabal.Completion.Completer.Module (fpToExposedModulePath)
32+
import Ide.Plugin.Cabal.Orphans ()
33+
import Ide.Plugin.Error
34+
import Ide.PluginUtils (mkLspCommand)
35+
import Ide.Types (CommandId (CommandId),
36+
PluginId)
37+
38+
import Control.Lens ((^.))
39+
import qualified Language.LSP.Protocol.Lens as JL
40+
import Language.LSP.Protocol.Types (CodeActionKind (..),
41+
VersionedTextDocumentIdentifier)
42+
import qualified Language.LSP.Protocol.Types as J
43+
import System.FilePath
44+
import Text.PrettyPrint (render)
45+
import Text.Regex.TDFA
46+
47+
--------------------------------------------
48+
-- Add module to cabal file
49+
--------------------------------------------
50+
51+
{- | Takes a path to a cabal file, a module path in exposed module syntax
52+
and the contents of the cabal file and generates all possible
53+
code actions for inserting the module into the cabal file
54+
with the given contents.
55+
-}
56+
collectModuleInsertionOptions ::
57+
(MonadIO m) =>
58+
Recorder (WithPriority Log) ->
59+
PluginId ->
60+
VersionedTextDocumentIdentifier ->
61+
J.Diagnostic ->
62+
-- | The file path of the cabal file to insert the new module into
63+
FilePath ->
64+
-- | The generic package description of the cabal file to insert the new module into.
65+
GenericPackageDescription ->
66+
-- | The URI of the unknown haskell file/new module to insert into the cabal file.
67+
Uri ->
68+
ExceptT PluginError m [J.CodeAction]
69+
collectModuleInsertionOptions _ plId txtDocIdentifier diag cabalFilePath gpd haskellFilePathURI = do
70+
haskellFilePath <- uriToFilePathE haskellFilePathURI
71+
let configs = concatMap (mkModuleInsertionConfig txtDocIdentifier cabalFilePath haskellFilePath) (makeStanzaItems gpd)
72+
pure $ map (mkCodeActionForModulePath plId diag) configs
73+
where
74+
makeStanzaItems :: GenericPackageDescription -> [StanzaItem]
75+
makeStanzaItems gpd =
76+
mainLibItem pd
77+
++ libItems pd
78+
++ executableItems pd
79+
++ testSuiteItems pd
80+
++ benchmarkItems pd
81+
where
82+
pd = flattenPackageDescription gpd
83+
84+
{- | Takes a buildInfo of a cabal file component as defined in the generic package description,
85+
and translates it to filepaths of the component's hsSourceDirs,
86+
to be processed for adding modules to exposed-, or other-modules fields in a cabal file.
87+
-}
88+
buildInfoToHsSourceDirs :: BuildInfo -> [FilePath]
89+
buildInfoToHsSourceDirs buildInfo = map getSymbolicPath hsSourceDirs'
90+
where
91+
hsSourceDirs' = hsSourceDirs buildInfo
92+
93+
{- | Takes the path to the cabal file to insert the module into,
94+
the module path to be inserted, and a stanza representation.
95+
96+
Returns a list of module insertion configs, where each config
97+
represents a possible place to insert the module.
98+
-}
99+
mkModuleInsertionConfig :: VersionedTextDocumentIdentifier -> FilePath -> FilePath -> StanzaItem -> [ModuleInsertionConfig]
100+
mkModuleInsertionConfig txtDocIdentifier cabalFilePath haskellFilePath (StanzaItem{..}) = do
101+
case mkRelativeModulePathM siHsSourceDirs cabalFilePath haskellFilePath of
102+
Just processedModPath ->
103+
[modInsertItem processedModPath "other-modules"]
104+
++ [modInsertItem processedModPath "exposed-modules" | CLibName _ <- [siComponent]]
105+
_ -> []
106+
where
107+
modInsertItem :: T.Text -> T.Text -> ModuleInsertionConfig
108+
modInsertItem modPath label =
109+
ModuleInsertionConfig
110+
{ targetFile = cabalFilePath
111+
, moduleToInsert = modPath
112+
, modVerTxtDocId = txtDocIdentifier
113+
, insertionStanza = siComponent
114+
, insertionLabel = label
115+
}
116+
117+
mkCodeActionForModulePath :: PluginId -> J.Diagnostic -> ModuleInsertionConfig -> J.CodeAction
118+
mkCodeActionForModulePath plId diag insertionConfig =
119+
J.CodeAction
120+
{ _title = "Add to " <> label <> " as " <> fieldName
121+
, _kind = Just CodeActionKind_Refactor
122+
, _diagnostics = Just [diag]
123+
, _isPreferred = Nothing
124+
, _disabled = Nothing
125+
, _edit = Nothing
126+
, _command = Just command
127+
, _data_ = Nothing
128+
}
129+
where
130+
fieldName = insertionLabel insertionConfig
131+
command = mkLspCommand plId (CommandId cabalAddModuleCommandId) "Add missing module" (Just [toJSON insertionConfig])
132+
label = T.pack $ CabalPretty.prettyShow $ insertionStanza insertionConfig
133+
134+
{- | Takes a list of source subdirectories, a cabal source path and a haskell filepath
135+
and returns a path to the module in exposed module syntax.
136+
The path will be relative to one of the subdirectories, in case the module is contained within one of them.
137+
-}
138+
mkRelativeModulePathM :: [FilePath] -> FilePath -> FilePath -> Maybe T.Text
139+
mkRelativeModulePathM hsSourceDirs cabalSrcPath' haskellFilePath =
140+
asum $
141+
map
142+
( \srcDir -> do
143+
let relMP = makeRelative (normalise (cabalSrcPath </> srcDir)) haskellFilePath
144+
if relMP == haskellFilePath then Nothing else Just $ fpToExposedModulePath cabalSrcPath relMP
145+
)
146+
hsSourceDirs
147+
where
148+
cabalSrcPath = takeDirectory cabalSrcPath'
149+
150+
isUnknownModuleDiagnostic :: J.Diagnostic -> Bool
151+
isUnknownModuleDiagnostic diag = (msg =~ regex)
152+
where
153+
msg :: T.Text
154+
msg = diag ^. JL.message
155+
regex :: T.Text
156+
regex = "Loading the module [\8216'][^\8217']*[\8217'] failed."
157+
158+
--------------------------
159+
-- Below are several utility functions which create a StanzaItem for each of the possible Stanzas,
160+
-- these all have specific constructors we need to match, so we can't generalise this process well.
161+
--------------------------
162+
163+
benchmarkItems :: PackageDescription -> [StanzaItem]
164+
benchmarkItems pd =
165+
map
166+
( \benchmark ->
167+
StanzaItem
168+
{ siComponent = CBenchName $ benchmarkName benchmark
169+
, siHsSourceDirs = buildInfoToHsSourceDirs $ benchmarkBuildInfo benchmark
170+
}
171+
)
172+
(benchmarks pd)
173+
174+
testSuiteItems :: PackageDescription -> [StanzaItem]
175+
testSuiteItems pd =
176+
map
177+
( \testSuite ->
178+
StanzaItem
179+
{ siComponent = CTestName $ testName testSuite
180+
, siHsSourceDirs = buildInfoToHsSourceDirs $ testBuildInfo testSuite
181+
}
182+
)
183+
(testSuites pd)
184+
185+
executableItems :: PackageDescription -> [StanzaItem]
186+
executableItems pd =
187+
map
188+
( \executable ->
189+
StanzaItem
190+
{ siComponent = CExeName $ exeName executable
191+
, siHsSourceDirs = buildInfoToHsSourceDirs $ buildInfo executable
192+
}
193+
)
194+
(executables pd)
195+
196+
libItems :: PackageDescription -> [StanzaItem]
197+
libItems pd =
198+
mapMaybe
199+
( \subLib ->
200+
case libName subLib of
201+
LSubLibName compName ->
202+
Just
203+
StanzaItem
204+
{ siComponent = CLibName $ LSubLibName compName
205+
, siHsSourceDirs = buildInfoToHsSourceDirs $ libBuildInfo subLib
206+
}
207+
_ -> Nothing
208+
)
209+
(subLibraries pd)
210+
211+
mainLibItem :: PackageDescription -> [StanzaItem]
212+
mainLibItem pd =
213+
case library pd of
214+
Just lib ->
215+
[ StanzaItem
216+
{ siComponent = CLibName LMainLibName
217+
, siHsSourceDirs = buildInfoToHsSourceDirs $ libBuildInfo lib
218+
}
219+
]
220+
Nothing -> []
221+
222+
--------------------------------------------
223+
-- Add dependency to a cabal file
224+
--------------------------------------------
225+
226+
{- | Creates a code action that calls the `cabalAddCommand`,
227+
using dependency-version suggestion pairs as input.
228+
229+
Returns disabled action if no cabal files given.
230+
231+
Takes haskell and cabal file paths to create a relative path
232+
to the haskell file, which is used to get a `BuildTarget`.
233+
-}
234+
addDependencySuggestCodeAction ::
235+
PluginId ->
236+
-- | Cabal's versioned text identifier
237+
VersionedTextDocumentIdentifier ->
238+
-- | A dependency-version suggestion pairs
239+
[(T.Text, T.Text)] ->
240+
-- | Path to the haskell file (source of diagnostics)
241+
FilePath ->
242+
-- | Path to the cabal file (that will be edited)
243+
FilePath ->
244+
GenericPackageDescription ->
245+
IO [J.CodeAction]
246+
addDependencySuggestCodeAction plId verTxtDocId suggestions haskellFilePath cabalFilePath gpd = do
247+
buildTargets <- liftIO $ getBuildTargets gpd cabalFilePath haskellFilePath
248+
case buildTargets of
249+
-- If there are no build targets found, run the `cabal-add` command with default behaviour
250+
[] -> pure $ mkCodeActionForDependency cabalFilePath Nothing <$> suggestions
251+
-- Otherwise provide actions for all found targets
252+
targets ->
253+
pure $
254+
concat
255+
[ mkCodeActionForDependency cabalFilePath (Just $ buildTargetToStringRepr target)
256+
<$> suggestions
257+
| target <- targets
258+
]
259+
where
260+
{- | Note the use of the `pretty` function.
261+
It converts the `BuildTarget` to an acceptable string representation.
262+
It will be used as the input for `cabal-add`'s `executeConfig`.
263+
-}
264+
buildTargetToStringRepr target = render $ CabalPretty.pretty $ buildTargetComponentName target
265+
266+
{- | Finds the build targets that are used in `cabal-add`.
267+
Note the unorthodox usage of `readBuildTargets`:
268+
If the relative path to the haskell file is provided,
269+
`readBuildTargets` will return the build targets, this
270+
module is mentioned in (either exposed-modules or other-modules).
271+
-}
272+
getBuildTargets :: GenericPackageDescription -> FilePath -> FilePath -> IO [BuildTarget]
273+
getBuildTargets gpd cabalFilePath haskellFilePath = do
274+
let haskellFileRelativePath = makeRelative (dropFileName cabalFilePath) haskellFilePath
275+
readBuildTargets (verboseNoStderr silent) (flattenPackageDescription gpd) [haskellFileRelativePath]
276+
277+
mkCodeActionForDependency :: FilePath -> Maybe String -> (T.Text, T.Text) -> J.CodeAction
278+
mkCodeActionForDependency cabalFilePath target (suggestedDep, suggestedVersion) =
279+
let
280+
versionTitle = if T.null suggestedVersion then T.empty else "-" <> suggestedVersion
281+
targetTitle = case target of
282+
Nothing -> T.empty
283+
Just t -> " at " <> T.pack t
284+
title = "Add dependency " <> suggestedDep <> versionTitle <> targetTitle
285+
version = if T.null suggestedVersion then Nothing else Just suggestedVersion
286+
287+
params =
288+
CabalAddDependencyCommandParams
289+
{ depCabalPath = cabalFilePath
290+
, depVerTxtDocId = verTxtDocId
291+
, depBuildTarget = target
292+
, depDependency = suggestedDep
293+
, depVersion = version
294+
}
295+
command = mkLspCommand plId (CommandId cabalAddDependencyCommandId) "Add dependency" (Just [toJSON params])
296+
in
297+
J.CodeAction title (Just CodeActionKind_QuickFix) (Just []) Nothing Nothing Nothing (Just command) Nothing
298+
299+
{- | Gives a mentioned number of @(dependency, version)@ pairs
300+
found in the "hidden package" diagnostic message.
301+
302+
For example, if a ghc error looks like this:
303+
304+
> "Could not load module ‘Data.List.Split’
305+
> It is a member of the hidden package ‘split-0.2.5’.
306+
> Perhaps you need to add ‘split’ to the build-depends in your .cabal file."
307+
308+
or this if PackageImports extension is used:
309+
310+
> "Could not find module ‘Data.List.Split’
311+
> Perhaps you meant
312+
> Data.List.Split (needs flag -package-id split-0.2.5)"
313+
314+
It extracts mentioned package names and version numbers.
315+
In this example, it will be @[("split", "0.2.5")]@
316+
317+
Also supports messages without a version.
318+
319+
> "Perhaps you need to add ‘split’ to the build-depends in your .cabal file."
320+
321+
Will turn into @[("split", "")]@
322+
-}
323+
hiddenPackageSuggestion :: J.Diagnostic -> [(T.Text, T.Text)]
324+
hiddenPackageSuggestion diag = getMatch (msg =~ regex)
325+
where
326+
msg :: T.Text
327+
msg = diag ^. JL.message
328+
regex :: T.Text
329+
regex =
330+
let regex' = "([a-zA-Z0-9-]*[a-zA-Z0-9])(-([0-9\\.]*))?"
331+
in "It is a member of the hidden package [\8216']"
332+
<> regex'
333+
<> "[\8217']"
334+
<> "|"
335+
<> "needs flag -package-id "
336+
<> regex'
337+
-- Have to do this matching because `Regex.TDFA` doesn't(?) support
338+
-- not-capturing groups like (?:message)
339+
getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> [(T.Text, T.Text)]
340+
getMatch (_, _, _, []) = []
341+
getMatch (_, _, _, [dependency, _, cleanVersion, "", "", ""]) = [(dependency, cleanVersion)]
342+
getMatch (_, _, _, ["", "", "", dependency, _, cleanVersion]) = [(dependency, cleanVersion)]
343+
getMatch (_, _, _, _) = []

0 commit comments

Comments
 (0)