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.

Author: VeryMilkyJoe

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

plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.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 (_, _, _, _) = []