Add inlay hints plugin

haskell-language-server.cabal

@@ -1188,6 +1188,60 @@ test-suite hls-gadt-plugin-tests
     , hls-test-utils              == 2.7.0.0
     , text
 
+
+-----------------------------
+-- inlay hints plugin
+-----------------------------
+
+flag inlayHints
+  description: Enable inlayHints plugin
+  default:     True
+  manual:      True
+
+common inlayHints
+  if flag(inlayHints)
+    build-depends: haskell-language-server:hls-inlay-hints-plugin
+    cpp-options: -DinlayHints
+
+library hls-inlay-hints-plugin
+  import:           defaults, pedantic, warnings
+  hs-source-dirs:   plugins/hls-inlay-hints-plugin/src
+  exposed-modules:
+    Ide.Plugin.InlayHints
+    Ide.Plugin.InlayHints.Types
+
+    Ide.Plugin.InlayHints.Fixity
+    Ide.Plugin.InlayHints.Hole
+    Ide.Plugin.InlayHints.LocalBinding
+  other-modules:
+    Ide.Plugin.InlayHints.Config
+  build-depends:
+      base                  >=4.12 && <5
+    , containers
+    , deepseq
+    , extra
+    , ghcide                == 2.7.0.0
+    , hashable
+    , hls-plugin-api        == 2.7.0.0
+    , lsp                   >=2.4
+    , mtl
+    , transformers
+    , text
+
+  default-extensions: DataKinds
+
+test-suite hls-inlay-hints-plugin-tests
+  import:           defaults, pedantic, test-defaults, warnings
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   plugins/hls-inlay-hints-plugin/test
+  main-is:          Main.hs
+  build-depends:
+    , base
+    , filepath
+    , haskell-language-server:hls-inlay-hints-plugin
+    , hls-test-utils              == 2.7.0.0
+    , text
+
 -----------------------------
 -- explicit fixity plugin
 -----------------------------
@@ -1777,6 +1831,7 @@ library
                   , overloadedRecordDot
                   , semanticTokens
                   , notes
+                  , inlayHints
 
   exposed-modules:
     Ide.Arguments

hls-plugin-api/src/Ide/Types.hs

@@ -541,7 +541,10 @@ instance PluginMethod Request Method_CallHierarchyOutgoingCalls where
     <> pluginFeatureEnabled plcCallHierarchyOn pluginDesc conf
 
 instance PluginMethod Request Method_WorkspaceExecuteCommand where
-  handlesRequest _ _ _ _= HandlesRequest
+  handlesRequest _ _ _ _ = HandlesRequest
+
+instance PluginMethod Request Method_TextDocumentInlayHint where
+  handlesRequest _ _ _ _ = HandlesRequest
 
 instance PluginMethod Request (Method_CustomMethod m) where
   handlesRequest _ _ _ _ = HandlesRequest
@@ -766,6 +769,9 @@ instance PluginRequestMethod Method_TextDocumentSemanticTokensFull where
 instance PluginRequestMethod Method_TextDocumentSemanticTokensFullDelta where
   combineResponses _ _ _ _ (x :| _) = x
 
+instance PluginRequestMethod Method_TextDocumentInlayHint where
+  combineResponses _ _ _ _ (x :| _) = x
+
 takeLefts :: [a |? b] -> [a]
 takeLefts = mapMaybe (\x -> [res | (InL res) <- Just x])
 

plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies      #-}
+
+module Ide.Plugin.InlayHints(descriptor) where
+
+import           Control.Monad.Cont                 (MonadIO (liftIO))
+import           Data.Foldable                      (traverse_)
+import           Development.IDE                    (IdeState, runAction)
+import           Development.IDE.Core.PluginUtils   (runActionE)
+import           Ide.Logger                         (Recorder, WithPriority)
+import           Ide.Plugin.Error                   (getNormalizedFilePathE)
+import           Ide.Plugin.InlayHints.Config       (InlayHintsConfig (..),
+                                                     getInlayHintsConfig,
+                                                     properties)
+import           Ide.Plugin.InlayHints.Fixity       (fixityInlayHints,
+                                                     fixityRule)
+import           Ide.Plugin.InlayHints.Hole         (holeInlayHints, holeRule)
+import           Ide.Plugin.InlayHints.LocalBinding (localBindingInlayHints,
+                                                     localBindingRule)
+import           Ide.Plugin.InlayHints.Types        (InlayHintLog)
+import           Ide.Types                          (ConfigDescriptor (configCustomConfig),
+                                                     PluginDescriptor (pluginConfigDescriptor, pluginHandlers, pluginRules),
+                                                     PluginId,
+                                                     defaultConfigDescriptor,
+                                                     defaultPluginDescriptor,
+                                                     mkCustomConfig,
+                                                     mkPluginHandler)
+import           Language.LSP.Protocol.Message      (SMethod (SMethod_TextDocumentInlayHint))
+import           Language.LSP.Protocol.Types        (InlayHintParams (InlayHintParams),
+                                                     Null (Null),
+                                                     TextDocumentIdentifier (TextDocumentIdentifier),
+                                                     type (|?) (InL, InR))
+
+descriptor :: Recorder (WithPriority InlayHintLog) -> PluginId -> PluginDescriptor IdeState
+descriptor recorder pluginId = (defaultPluginDescriptor pluginId "Provides Info in Inlay Hints")
+    { pluginRules = traverse_ ($ recorder) [
+        fixityRule
+        , holeRule
+        , localBindingRule
+        ]
+    , pluginHandlers =
+        mkPluginHandler SMethod_TextDocumentInlayHint
+        $ \state _pid (InlayHintParams _ (TextDocumentIdentifier uri) _) -> do
+            nfp <- getNormalizedFilePathE uri
+            runActionE "InlayHints" state $ do
+                inlayHintsCfg <- liftIO $ runAction "inlay hints: config" state $ getInlayHintsConfig pluginId
+                let optional p x = if any ($ inlayHintsCfg) [p, enableAll]
+                                   then x
+                                   else const $ pure (InL [])
+
+                fmap (foldr (<>) (InR Null)) $ traverse (($ nfp) . uncurry optional) [
+                    (enableFixity, fixityInlayHints)
+                    , (enableHole, holeInlayHints)
+                    , (enableLocalBinding, localBindingInlayHints)
+                    ]
+    , pluginConfigDescriptor = defaultConfigDescriptor
+      { configCustomConfig = mkCustomConfig properties
+      }
+    }

plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Config.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE OverloadedLabels  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Ide.Plugin.InlayHints.Config (
+    InlayHintsConfig(..),
+    getInlayHintsConfig,
+    properties
+) where
+
+import           Development.IDE       (Action, usePropertyAction)
+import           Ide.Plugin.Properties
+import           Ide.Types             (PluginId)
+
+-- | The Inlay Hints plugin configuration. (see 'properties')
+data InlayHintsConfig = InlayHintsConfig
+  { enableAll          :: Bool
+  , enableFixity       :: Bool
+  , enableHole         :: Bool
+  , enableLocalBinding :: Bool
+  }
+  deriving (Eq, Ord, Show)
+
+properties :: Properties
+    '[ 'PropertyKey "all" 'TBoolean
+    , 'PropertyKey "fixity" 'TBoolean
+    , 'PropertyKey "hole" 'TBoolean
+    , 'PropertyKey "localBinding" 'TBoolean
+    ]
+properties = emptyProperties
+    & defineBooleanProperty #localBinding
+      "Enable the local binding type (e.g. `let`) inlay hints" False
+    & defineBooleanProperty #hole
+      "Enable the hole type inlay hints" False
+    & defineBooleanProperty #fixity
+      "Enable the operator fixity inlay hints" False
+    & defineBooleanProperty #all
+      "Enable ALL inlay hints" False
+
+getInlayHintsConfig :: PluginId -> Action InlayHintsConfig
+getInlayHintsConfig plId =
+    InlayHintsConfig
+    <$> usePropertyAction #all plId properties
+    <*> usePropertyAction #fixity plId properties
+    <*> usePropertyAction #hole plId properties
+    <*> usePropertyAction #localBinding plId properties

plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Fixity.hs

@@ -0,0 +1,130 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies      #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module Ide.Plugin.InlayHints.Fixity(fixityRule, fixityInlayHints) where
+
+import           Control.DeepSeq                      (NFData (rnf), rwhnf)
+import           Control.Monad.Except                 (ExceptT)
+import           Control.Monad.IO.Class               (MonadIO (liftIO))
+import           Data.Either                          (isRight)
+import           Data.Hashable                        (Hashable)
+import qualified Data.Map.Strict                      as M
+import           Data.Maybe                           (fromMaybe)
+import qualified Data.Text                            as T
+import           Development.IDE                      (Action,
+                                                       GhcSessionDeps (GhcSessionDeps),
+                                                       HieAstResult (HAR, refMap),
+                                                       NormalizedFilePath,
+                                                       Position (Position),
+                                                       RuleResult, Rules,
+                                                       TcModuleResult (tmrTypechecked),
+                                                       TypeCheck (TypeCheck),
+                                                       cmapWithPrio, define,
+                                                       hscEnv, use_)
+import           Development.IDE.Core.PluginUtils     (useWithStaleE)
+import           Development.IDE.Core.PositionMapping (idDelta)
+import           Development.IDE.Core.RuleTypes       (GetHieAst (GetHieAst))
+import           Development.IDE.Core.Shake           (addPersistentRule)
+import           Development.IDE.GHC.Compat           (Fixity (Fixity), Name,
+                                                       TcGblEnv, defaultFixity,
+                                                       initTcWithGbl,
+                                                       lookupFixityRn,
+                                                       mkRealSrcLoc,
+                                                       realSrcLocSpan,
+                                                       realSrcSpanEnd,
+                                                       srcLocCol, srcLocLine)
+import           Development.IDE.GHC.Compat.Core      (HscEnv)
+import qualified Development.IDE.GHC.Compat.Util      as Util
+import           Development.IDE.GHC.Util             (printOutputable)
+import           GHC.Generics                         (Generic)
+import           Ide.Logger                           (Recorder, WithPriority)
+import           Ide.Plugin.Error                     (PluginError)
+import           Ide.Plugin.InlayHints.Types          (InlayHintLog (LogShake))
+import           Language.LSP.Protocol.Types          (InlayHint (InlayHint),
+                                                       Null, maybeToNull,
+                                                       type (|?) (InL))
+
+-------
+
+fixityInlayHints :: NormalizedFilePath -> ExceptT PluginError Action ([InlayHint] |? Null)
+fixityInlayHints nfp = do
+    (FixityMap fixmap, _) <- useWithStaleE GetFixity nfp
+    pure $ maybeToNull $ toAbsInlayHints fixmap
+    where
+        toAbsInlayHints :: M.Map Position Fixity -> Maybe [InlayHint]
+        toAbsInlayHints fixmap =
+            Just (M.elems $ M.mapWithKey (\(Position x y) (Fixity _ pre direction) ->
+              InlayHint
+                (Position (x - 1) (y - 1))
+                -- infixr => r
+                (InL ((T.takeEnd 1 $ printOutputable direction)
+                      <> printOutputable pre))
+                Nothing Nothing Nothing Nothing Nothing Nothing
+              ) fixmap)
+
+-------
+
+newtype FixityMap = FixityMap (M.Map Position Fixity)
+instance Show FixityMap where
+  show _ = "FixityMap"
+
+instance NFData FixityMap where
+  rnf (FixityMap xs) = rnf xs
+
+instance NFData Fixity where
+  rnf = rwhnf
+
+data GetFixity = GetFixity deriving (Show, Eq, Generic)
+
+instance Hashable GetFixity
+instance NFData GetFixity
+
+type instance RuleResult GetFixity = FixityMap
+
+fixityRule :: Recorder (WithPriority InlayHintLog) -> Rules ()
+fixityRule recorder = do
+    define (cmapWithPrio LogShake recorder) $ \GetFixity nfp -> do
+        HAR{refMap} <- use_ GetHieAst nfp
+        -- deps necessary so that we can consult already loaded in ifaces instead of loading in duplicates
+        env <- hscEnv <$> use_ GhcSessionDeps nfp
+        tcGblEnv <- tmrTypechecked <$> use_ TypeCheck nfp
+        fs <- lookupFixities env tcGblEnv $
+            M.mapKeys (\(Right x) -> x)
+            $ M.filterWithKey (\k _ -> isRight k)
+            $ M.map
+                (fmap $ (\loc ->
+                    Position (fromIntegral $ srcLocLine loc)
+                             (fromIntegral $ srcLocCol loc))
+                . realSrcSpanEnd
+                . fst)
+                refMap
+        pure ([], Just (FixityMap fs))
+
+    -- Ensure that this plugin doesn't block on startup
+    addPersistentRule GetFixity $ const $ pure $ Just (FixityMap M.empty, idDelta, Nothing)
+
+-- | Convert a HieAST to FixityTree with fixity info gathered
+lookupFixities :: MonadIO m => HscEnv -> TcGblEnv -> M.Map Name [Position] -> m (M.Map Position Fixity)
+lookupFixities hscEnv tcGblEnv names
+    = liftIO
+    $ fmap (fromMaybe M.empty . snd)
+    $ initTcWithGbl hscEnv tcGblEnv (realSrcLocSpan $ mkRealSrcLoc "<dummy>" 1 1)
+    $ M.traverseMaybeWithKey (\_ v -> v)
+    $ M.fromList
+    $ concat
+    $ M.elems
+    $ M.mapWithKey lookupFixity names
+  where
+    lookupFixity name positions =
+      fmap (,fixity) positions
+      where
+        fixity = do
+          f <- Util.handleGhcException
+            (const $ pure Nothing)
+            (Just <$> lookupFixityRn name)
+          if f == Just defaultFixity
+          then pure Nothing
+          else pure f