diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 3f38abe391..93843e501e 100644 --- a/haskell-language-server.cabal +++ b/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 diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 9ed6fd19b9..8843d14449 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/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]) diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs new file mode 100644 index 0000000000..05a32f4ab7 --- /dev/null +++ b/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 + } + } diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Config.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Config.hs new file mode 100644 index 0000000000..e35ce84c19 --- /dev/null +++ b/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 diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Fixity.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Fixity.hs new file mode 100644 index 0000000000..e6f3c98844 --- /dev/null +++ b/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 "" 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 diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Hole.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Hole.hs new file mode 100644 index 0000000000..57193b054b --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Hole.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Ide.Plugin.InlayHints.Hole (holeInlayHints, holeRule) where + +import Control.DeepSeq (NFData (rnf)) +import Control.Monad.Except (ExceptT) +import qualified Control.Monad.Extra as M +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Maybe (MaybeT (..)) +import Data.Hashable (Hashable) +import qualified Data.Map as M +import Data.Maybe (maybeToList) +import qualified Data.Text as T +import Development.IDE (Action, + GetHieAst (GetHieAst), + HieKind (HieFresh, HieFromDisk), + Position, Range (_end), + Recorder, RuleResult, + Rules, WithPriority, + cmapWithPrio, define, + printOutputable, + realSrcSpanToRange) +import Development.IDE.Core.PluginUtils (useE, useWithStaleMT) +import Development.IDE.Core.PositionMapping (idDelta) +import Development.IDE.Core.RuleTypes (HieAstResult (..)) +import Development.IDE.Core.Shake (addPersistentRule) +import Development.IDE.GHC.Compat (HieAST (..), + HieASTs (..), + HieFile (hie_types), + NodeInfo (..), + hieTypeToIface, + nodeAnnotations, + nodeInfo, nodeInfo', + recoverFullType) +import Development.IDE.Types.Location (NormalizedFilePath) +import GHC.Generics (Generic) +import Ide.Plugin.Error (PluginError) +import Ide.Plugin.InlayHints.Types (InlayHintLog (LogShake)) +import Language.LSP.Protocol.Types (InlayHint (InlayHint), + Null, type (|?) (InL)) + +------- + +holeInlayHints :: NormalizedFilePath -> ExceptT PluginError Action ([InlayHint] |? Null) +holeInlayHints nfp = do + (HoleMap hmap) <- useE GetHoles nfp + pure $ InL $ toAbsInlayHints hmap + where + toAbsInlayHints :: M.Map Position T.Text -> [InlayHint] + toAbsInlayHints hmap = + M.elems $ M.mapWithKey (\pos content -> + InlayHint pos (InL $ " :: " <> content) + Nothing Nothing Nothing Nothing Nothing Nothing) hmap + +------- + +holeRule :: Recorder (WithPriority InlayHintLog) -> Rules () +holeRule recorder = do + define (cmapWithPrio LogShake recorder) $ \GetHoles nfp -> do + holes <- lookupHoles nfp + pure ([], Just holes) + + -- Ensure that this plugin doesn't block on startup + addPersistentRule GetHoles $ const $ pure $ Just (HoleMap M.empty, idDelta, Nothing) + +------- + +newtype HoleMap = HoleMap (M.Map Position T.Text) +instance Show HoleMap where + show _ = "LocalBindingMap" + +instance NFData HoleMap where + rnf (HoleMap map) = rnf map + +data GetHoles = GetHoles deriving (Show, Eq, Generic) + +instance Hashable GetHoles +instance NFData GetHoles + +type instance RuleResult GetHoles = HoleMap + +lookupHoles + :: NormalizedFilePath + -> Action HoleMap +lookupHoles nfp + = flip fmap (getAtPoints nfp) $ \case + Just hm -> hm + Nothing -> HoleMap M.empty + +getAtPoints + :: NormalizedFilePath + -> Action (Maybe HoleMap) +getAtPoints nfp = runMaybeT $ do + (har, _) <- useWithStaleMT GetHieAst nfp + MaybeT $ liftIO $ Just . HoleMap <$> atPoints har + + +atPoints + :: HieAstResult + -> IO (M.Map Position T.Text) +atPoints (HAR _ hf _ _ (kind :: HieKind hietype)) = + fmap M.fromList $ M.concatMapM inlayHintInfo $ M.elems (getAsts hf) + where + inlayHintInfo :: HieAST hietype -> IO [(Position, T.Text)] + inlayHintInfo = return . inlayHintInfo' + where + inlayHintInfo' :: HieAST hietype -> [(Position, T.Text)] + inlayHintInfo' ast = case nodeChildren ast of + [] -> maybeToList (toPrettyName ast) + asts -> concatMap inlayHintInfo' asts + + toPrettyName :: HieAST hietype -> Maybe (Position, T.Text) + toPrettyName ast = (pos ast,) <$> toPrettyType ast + + pos :: HieAST hietype -> Position + pos ast = _end (realSrcSpanToRange $ nodeSpan ast) + + info :: HieAST hietype -> NodeInfo hietype + info ast = nodeInfoH kind ast + + prettyType :: hietype -> T.Text + prettyType t = case kind of + HieFresh -> printOutputable t + HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file) + + firstHole :: HieAST hietype -> Maybe hietype + firstHole ast = + let astInfo = info ast + -- TODO: need ONLY hole + -- Maybe there's only one solution left: regex diagnostic :( + isHole = (==) "HsUnboundVar" . fst + nullIds = M.null $ nodeIdentifiers astInfo + in case nodeType astInfo of + (x:_) | (any isHole $ nodeAnnotations astInfo) && nullIds -> Just x + _ -> Nothing + + toPrettyType :: HieAST hietype -> Maybe T.Text + toPrettyType = fmap prettyType . firstHole + +-- In ghc9, nodeInfo is monomorphic, so we need a case split here +nodeInfoH :: HieKind a -> HieAST a -> NodeInfo a +nodeInfoH (HieFromDisk _) = nodeInfo' +nodeInfoH HieFresh = nodeInfo diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/LocalBinding.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/LocalBinding.hs new file mode 100644 index 0000000000..47cba074b0 --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/LocalBinding.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Ide.Plugin.InlayHints.LocalBinding (localBindingRule, localBindingInlayHints) where + +import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData (rnf)) +import Control.Monad.Except (ExceptT) +import qualified Control.Monad.Extra as M +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Maybe (MaybeT (..)) +import Data.Hashable (Hashable) +import qualified Data.Map as M +import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.Text as T +import Development.IDE (Action, + DocAndTyThingMap (DKMap), + GetDocMap (GetDocMap), + GetHieAst (GetHieAst), + HieKind (HieFresh, HieFromDisk), + Position, Range (_end), + Recorder, RuleResult, + Rules, WithPriority, + cmapWithPrio, define, + printOutputable, + realSrcSpanToRange) +import Development.IDE.Core.PluginUtils (useE, useWithStaleMT) +import Development.IDE.Core.PositionMapping (idDelta) +import Development.IDE.Core.RuleTypes (HieAstResult (..)) +import Development.IDE.Core.Shake (addPersistentRule) +import Development.IDE.GHC.Compat (BindType (RegularBind), + ContextInfo (TyDecl, ValBind), + HieAST (..), + HieASTs (..), + HieFile (hie_types), + Identifier, + IdentifierDetails (..), + NodeInfo (..), + Scope (LocalScope), + hieTypeToIface, + lookupNameEnv, nodeInfo, + nodeInfo', + recoverFullType) +import Development.IDE.Spans.Common (TyThingMap, + safeTyThingType) +import Development.IDE.Types.Location (NormalizedFilePath) +import GHC.Generics (Generic) +import Ide.Plugin.Error (PluginError) +import Ide.Plugin.InlayHints.Types (InlayHintLog (LogShake)) +import Language.LSP.Protocol.Types (InlayHint (InlayHint), + Null, type (|?) (InL)) + +------- + +localBindingInlayHints :: NormalizedFilePath -> ExceptT PluginError Action ([InlayHint] |? Null) +localBindingInlayHints nfp = do + (LocalBindingMap hmap) <- useE GetLocalBinding nfp + pure $ InL $ toAbsInlayHints hmap + where + toAbsInlayHints :: M.Map Position T.Text -> [InlayHint] + toAbsInlayHints hmap = + M.elems $ M.mapWithKey (\pos content -> + InlayHint pos (InL $ " :: " <> content) + Nothing Nothing Nothing Nothing Nothing Nothing) hmap + +------- + +localBindingRule :: Recorder (WithPriority InlayHintLog) -> Rules () +localBindingRule recorder = do + define (cmapWithPrio LogShake recorder) $ \GetLocalBinding nfp -> do + bindings <- lookupLocalBindings nfp + pure ([], Just bindings) + + -- Ensure that this plugin doesn't block on startup + addPersistentRule GetLocalBinding $ const $ pure $ Just (LocalBindingMap M.empty, idDelta, Nothing) + +newtype LocalBindingMap = LocalBindingMap (M.Map Position T.Text) +instance Show LocalBindingMap where + show _ = "LocalBindingMap" + +instance NFData LocalBindingMap where + rnf (LocalBindingMap map) = rnf map + +data GetLocalBinding = GetLocalBinding deriving (Show, Eq, Generic) + +instance Hashable GetLocalBinding +instance NFData GetLocalBinding + +type instance RuleResult GetLocalBinding = LocalBindingMap + +lookupLocalBindings + :: NormalizedFilePath + -> Action LocalBindingMap +lookupLocalBindings nfp + = flip fmap (getAtPoints nfp) $ \case + Just hm -> hm + Nothing -> LocalBindingMap M.empty + +getAtPoints + :: NormalizedFilePath + -> Action (Maybe LocalBindingMap) +getAtPoints nfp = runMaybeT $ do + (har, _) <- useWithStaleMT GetHieAst nfp + (DKMap _ km) <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleMT GetDocMap nfp) + + MaybeT + $ liftIO + $ Just . LocalBindingMap + <$> atPoints har km + + +atPoints + :: HieAstResult + -> TyThingMap + -> IO (M.Map Position T.Text) +atPoints (HAR _ hf _ _ (kind :: HieKind hietype)) km = + fmap M.fromList $ M.concatMapM inlayHintInfo $ M.elems (getAsts hf) + where + inlayHintInfo :: HieAST hietype -> IO [(Position, T.Text)] + inlayHintInfo = return . inlayHintInfo' + where + inlayHintInfo' :: HieAST hietype -> [(Position, T.Text)] + inlayHintInfo' ast = + M.toList $ M.mapMaybe id $ M.map prettyName (filteredIdentifiers (flattenAST ast)) + + flattenAST :: HieAST hietype -> [HieAST hietype] + flattenAST ast = case nodeChildren ast of + [] -> [ast] + asts -> concatMap flattenAST asts + + pos :: HieAST hietype -> Position + pos ast = _end (realSrcSpanToRange $ nodeSpan ast) + + info :: HieAST hietype -> NodeInfo hietype + info ast = nodeInfoH kind ast + + -- TODO: This is damn messy, but I don't know how to do it better + filteredIdentifiers :: [HieAST hietype] -> M.Map Position (Identifier, IdentifierDetails hietype) + filteredIdentifiers asts = M.fromList $ fmap (\(idr, (pos, idrd)) -> (pos, (idr, idrd))) $ M.toList $ + (M.fromList $ fmap (\((idr, idrd), pos) -> (idr, (pos, idrd))) localBindList) + `M.difference` + (M.fromList $ fmap (\((idr, idrd), pos) -> (idr, (pos, idrd))) hasSigDeclList) + where + allNodeIdentifiers' = fmap (\ast -> + (case M.toList $ nodeIdentifiers $ info ast of + [(k, v)] -> Just (k, v) + _ -> Nothing + , pos ast) + ) asts + localBindList = + mapMaybe + (\(a, b) -> fmap (,b) a) + [ (node, pos) | (node, pos) <- allNodeIdentifiers', any (any bindLocal . identInfo . snd) node ] + hasSigDeclList = + mapMaybe + (\(a, b) -> fmap (,b) a) + [ (node, pos) | (node, pos) <- allNodeIdentifiers', any (any hasSigDecl . identInfo . snd) node ] + + bindLocal, hasSigDecl :: ContextInfo -> Bool + bindLocal (ValBind RegularBind (LocalScope _) _) = True + bindLocal _ = False + hasSigDecl TyDecl = True + hasSigDecl _ = False + + prettyName :: (Identifier, IdentifierDetails hietype) -> Maybe T.Text + prettyName (Right n, dets) = + Just $ fromMaybe "?" ((prettyType <$> identType dets) <|> maybeKind) + where + maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n + prettyName (Left _, _) = Nothing + + prettyType :: hietype -> T.Text + prettyType t = case kind of + HieFresh -> printOutputable t + HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file) + +-- In ghc9, nodeInfo is monomorphic, so we need a case split here +nodeInfoH :: HieKind a -> HieAST a -> NodeInfo a +nodeInfoH (HieFromDisk _) = nodeInfo' +nodeInfoH HieFresh = nodeInfo diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Types.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Types.hs new file mode 100644 index 0000000000..27a58fa98e --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Types.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LambdaCase #-} + +module Ide.Plugin.InlayHints.Types(InlayHintLog(LogShake)) where + +import Development.IDE (Pretty (pretty)) +import qualified Development.IDE.Core.Shake as Shake + +newtype InlayHintLog = LogShake Shake.Log + +instance Pretty InlayHintLog where + pretty = \case + LogShake log -> pretty log + diff --git a/plugins/hls-inlay-hints-plugin/test/Main.hs b/plugins/hls-inlay-hints-plugin/test/Main.hs new file mode 100644 index 0000000000..9e4e9db2e7 --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/test/Main.hs @@ -0,0 +1,12 @@ +module Main (main) where + +main :: IO () +main = + let + greeting :: String + greeting = "Bonjour" + greetings = unwords $ replicate times greeting; + who = "Tom" + times = 123; + in + putStrLn $ unwords [ greetings, who ] diff --git a/plugins/hls-inlay-hints-plugin/test/testdata/Hover.hs b/plugins/hls-inlay-hints-plugin/test/testdata/Hover.hs new file mode 100644 index 0000000000..d7fa47220c --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/test/testdata/Hover.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE RecordWildCards #-} +module Hover where +import Control.Applicative ((<|>)) +import Control.Monad +import Data.Function (on) +f1 = (++) +f2 = ($) +f3 = (.) +f4 = (+) +f5 = 1 - 2 +f6 = (<>) +f7 = (>>=) +f8 = (>=>) +f9 = elem +f10 = on +f11 = (||) +f12 = mod +f13 = (**) +f14 = (^) +f15 = (<$) +f16 = seq +f17 = (<|>) + +infixr 7 >>: +infix 9 >>:: +data F = G + { (>>:) :: Int -> Int -> Int + , c :: Int + , (>>::) :: Char + } +f G{..} = undefined + +infixl 1 `f` + +infixr 9 >>>: +(>>>:) :: Int -> Int +(>>>:) x = 3 + +infixl 3 ~\: +(~\:) x y = 3 diff --git a/plugins/hls-inlay-hints-plugin/test/testdata/HoverImport.hs b/plugins/hls-inlay-hints-plugin/test/testdata/HoverImport.hs new file mode 100644 index 0000000000..95a7de10cd --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/test/testdata/HoverImport.hs @@ -0,0 +1,5 @@ +module HoverImport where + +import Hover + +g = (>>>:) diff --git a/plugins/hls-inlay-hints-plugin/test/testdata/hie.yaml b/plugins/hls-inlay-hints-plugin/test/testdata/hie.yaml new file mode 100644 index 0000000000..824558147d --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/test/testdata/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: + arguments: [] diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 1f5d091dc5..8dafd4e320 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -85,6 +85,10 @@ import qualified Ide.Plugin.GADT as GADT import qualified Ide.Plugin.ExplicitFixity as ExplicitFixity #endif +#if inlayHints +import qualified Ide.Plugin.InlayHints as InlayHints +#endif + #if explicitFields import qualified Ide.Plugin.ExplicitFields as ExplicitFields #endif @@ -238,6 +242,9 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins #if explicitFixity let pId = "explicit-fixity" in ExplicitFixity.descriptor (pluginRecorder pId) pId : #endif +#if inlayHints + let pId = "inlay-hints" in InlayHints.descriptor (pluginRecorder pId) pId : +#endif #if explicitFields let pId = "explicit-fields" in ExplicitFields.descriptor (pluginRecorder pId) pId : #endif