Introduce Ide.Plugin.Cabal.Dependencies module

Author: batkot

haskell-language-server.cabal

@@ -242,6 +242,7 @@ library hls-cabal-plugin
   exposed-modules:
     Ide.Plugin.Cabal
     Ide.Plugin.Cabal.Diagnostics
+    Ide.Plugin.Cabal.Dependencies
     Ide.Plugin.Cabal.Completion.CabalFields
     Ide.Plugin.Cabal.Completion.Completer.FilePath
     Ide.Plugin.Cabal.Completion.Completer.Module

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

@@ -3,7 +3,7 @@
 {-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ViewPatterns          #-}
 
 module Ide.Plugin.Cabal (descriptor, haskellInteractionDescriptor, Log (..)) where
 
@@ -56,6 +56,7 @@ import           Ide.Plugin.Cabal.Completion.Types             (ParseCabalCommon
                                                                 ParseCabalFile (..))
 import qualified Ide.Plugin.Cabal.Completion.Types             as Types
 import           Ide.Plugin.Cabal.Definition                   (gotoDefinition)
+import qualified Ide.Plugin.Cabal.Dependencies                 as Dependencies
 import qualified Ide.Plugin.Cabal.Diagnostics                  as Diagnostics
 import qualified Ide.Plugin.Cabal.FieldSuggest                 as FieldSuggest
 import qualified Ide.Plugin.Cabal.LicenseSuggest               as LicenseSuggest
@@ -69,9 +70,6 @@ import qualified Language.LSP.Protocol.Message                 as LSP
 import           Language.LSP.Protocol.Types
 import qualified Language.LSP.VFS                              as VFS
 import           Text.Regex.TDFA
-import Development.IDE.GHC.Compat (getUnitInfoMap, unitPackageNameString, unitPackageVersion, filterUniqMap, nonDetEltsUniqMap)
-import Data.Version (Version(..))
-import qualified Data.Char as Char
 
 data Log
   = LogModificationTime NormalizedFilePath FileVersion
@@ -385,44 +383,9 @@ hints :: PluginMethodHandler IdeState LSP.Method_TextDocumentInlayHint
 hints state _plId clp = do
   let uri = clp ^. JL.textDocument . JL.uri
   nfp <- getNormalizedFilePathE uri
-  cabalFields <- runActionE "cabal.cabal-lens" state $ useE ParseCabalFields nfp
-  (hscEnv -> hsc) <- runActionE "classplugin.codeAction.GhcSession" state $ useE GhcSession nfp
-  let lookupVersion pkgName = Maybe.listToMaybe $ nonDetEltsUniqMap $ fmap unitPackageVersion $ filterUniqMap ((==) pkgName . unitPackageNameString) $ getUnitInfoMap hsc
-  pure $ InL $ fmap hint $ collectPackageVersions (fmap printVersion . lookupVersion . T.unpack) =<< cabalFields
-  where
-    collectPackageVersions :: (T.Text -> Maybe T.Text) -> Syntax.Field Syntax.Position -> [(Syntax.Position, LicenseSuggest.Text)]
-    collectPackageVersions lookupVersion (Syntax.Field (Syntax.Name _ "build-depends") pos) = concatMap (fieldLinePackageVersions lookupVersion) pos
-    collectPackageVersions lookupVersion (Syntax.Section _ _ fields) = concatMap (collectPackageVersions lookupVersion) fields
-    collectPackageVersions _ _ = []
-
-    fieldLinePackageVersions :: (T.Text -> Maybe T.Text) -> Syntax.FieldLine Syntax.Position -> [(Syntax.Position, LicenseSuggest.Text)]
-    fieldLinePackageVersions lookupVersion (Syntax.FieldLine pos x) =
-      let splitted = T.splitOn "," $ Encoding.decodeUtf8Lenient x
-          calcStartPosition (prev, start) = T.length prev + 1 + start
-          potentialPkgs = List.foldl' (\a b -> a <> [(b, Maybe.maybe 0 calcStartPosition $ Maybe.listToMaybe $ reverse a)]) [] splitted
-          versions = do
-            (pkg', pkgStartOffset) <- potentialPkgs
-            let pkgName = T.takeWhile (not . Char.isSpace) . T.strip $ pkg'
-                endOfPackage = T.length pkgName + (T.length $ T.takeWhile Char.isSpace pkg')
-            version <- Maybe.maybeToList $ lookupVersion $ T.takeWhile (not . Char.isSpace) . T.strip $ pkg'
-            pure (Syntax.Position (Syntax.positionRow pos) (Syntax.positionCol pos + pkgStartOffset + endOfPackage), version)
-       in versions
-
-    printVersion v = T.intercalate "." (fmap (T.pack . show) $ versionBranch v)
-
-    hint :: (Syntax.Position, LicenseSuggest.Text) -> InlayHint
-    hint (pos, foo) =
-      let cPos = Types.cabalPositionToLSPPosition pos
-          mkInlayHintLabelPart = InlayHintLabelPart (" (" <> foo <> ")") Nothing Nothing Nothing
-      in  InlayHint { _position = cPos
-                    , _label = InR $ pure mkInlayHintLabelPart
-                    , _kind = Nothing -- neither a type nor a parameter
-                    , _textEdits = Nothing -- same as CodeAction
-                    , _tooltip = Nothing
-                    , _paddingLeft = Nothing
-                    , _paddingRight = Nothing
-                    , _data_ = Nothing
-                    }
+  cabalFields <- runActionE "cabal.cabal-hints" state $ useE ParseCabalFields nfp
+  (hscEnv -> hsc) <- runActionE "cabal.cabal-hints" state $ useE GhcSession nfp
+  pure $ InL $ Dependencies.dependencyVersionHints cabalFields hsc
 
 -- | Handler for hover messages.
 --

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

@@ -0,0 +1,62 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Ide.Plugin.Cabal.Dependencies (dependencyVersionHints, collectPackageDependencyVersions) where
+
+import qualified Data.Char                         as Char
+import qualified Data.List                         as List
+import qualified Data.Maybe                        as Maybe
+import qualified Data.Text                         as T
+import qualified Data.Text.Encoding                as Encoding
+import           Data.Version                      (Version (..))
+import           Development.IDE.GHC.Compat        (HscEnv, filterUniqMap,
+                                                    getUnitInfoMap,
+                                                    nonDetEltsUniqMap,
+                                                    unitPackageNameString,
+                                                    unitPackageVersion)
+import qualified Distribution.Fields               as Syntax
+import qualified Distribution.Parsec.Position      as Syntax
+import qualified Ide.Plugin.Cabal.Completion.Types as Types
+import           Language.LSP.Protocol.Types       (InlayHint (..),
+                                                    InlayHintLabelPart (InlayHintLabelPart),
+                                                    type (|?) (..))
+
+dependencyVersionHints ::  [Syntax.Field Syntax.Position] -> HscEnv -> [InlayHint]
+dependencyVersionHints cabalFields = fmap mkHint . collectPackageDependencyVersions cabalFields
+  where
+    mkHint :: (Syntax.Position, Version) -> InlayHint
+    mkHint (pos, dependencyVersion) =
+      let mkInlayHintLabelPart = InlayHintLabelPart (" (" <> printVersion dependencyVersion <> ")") Nothing Nothing Nothing
+      in  InlayHint { _position = Types.cabalPositionToLSPPosition pos
+                    , _label = InR $ pure mkInlayHintLabelPart
+                    , _kind = Nothing
+                    , _textEdits = Nothing
+                    , _tooltip = Nothing
+                    , _paddingLeft = Nothing
+                    , _paddingRight = Nothing
+                    , _data_ = Nothing
+                    }
+
+collectPackageDependencyVersions :: [Syntax.Field Syntax.Position] -> HscEnv -> [(Syntax.Position, Version)]
+collectPackageDependencyVersions cabalFields hscEnv = cabalFields >>= collectPackageVersions
+  where
+    lookupPackageVersion pkgName = Maybe.listToMaybe $ nonDetEltsUniqMap $ fmap unitPackageVersion $ filterUniqMap ((==) (T.unpack pkgName) . unitPackageNameString) $ getUnitInfoMap hscEnv
+
+    collectPackageVersions :: Syntax.Field Syntax.Position -> [(Syntax.Position, Version)]
+    collectPackageVersions (Syntax.Field (Syntax.Name _ "build-depends") pos) = concatMap fieldLinePackageVersions pos
+    collectPackageVersions (Syntax.Section _ _ fields) = concatMap collectPackageVersions fields
+    collectPackageVersions _ = []
+
+    fieldLinePackageVersions :: Syntax.FieldLine Syntax.Position -> [(Syntax.Position, Version)]
+    fieldLinePackageVersions (Syntax.FieldLine pos x) =
+      let splitted = T.splitOn "," $ Encoding.decodeUtf8Lenient x
+          calcStartPosition (prev, start) = T.length prev + 1 + start
+          potentialPkgs = List.foldl' (\a b -> a <> [(b, Maybe.maybe 0 calcStartPosition $ Maybe.listToMaybe $ reverse a)]) [] splitted
+          versions = do
+            (pkg', pkgStartOffset) <- potentialPkgs
+            let pkgName = T.takeWhile (not . Char.isSpace) . T.strip $ pkg'
+                endOfPackage = T.length pkgName + (T.length $ T.takeWhile Char.isSpace pkg')
+            version <- Maybe.maybeToList $ lookupPackageVersion $ T.takeWhile (not . Char.isSpace) . T.strip $ pkg'
+            pure (Syntax.Position (Syntax.positionRow pos) (Syntax.positionCol pos + pkgStartOffset + endOfPackage), version)
+       in versions
+
+printVersion :: Version -> T.Text
+printVersion v = T.intercalate "." (fmap (T.pack . show) $ versionBranch v)