Skip to content

Commit 5728eff

Browse files
akrmnakrmn
committed
Add support for :info[!] command in Eval plugin
1 parent 4e6e964 commit 5728eff

File tree

1 file changed

+74
-10
lines changed

1 file changed

+74
-10
lines changed

‎plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs

Lines changed: 74 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -40,7 +40,7 @@ import Data.Char (isSpace)
4040
import qualified Data.DList as DL
4141
import qualified Data.HashMap.Strict as HashMap
4242
import Data.List (dropWhileEnd, find,
43-
intercalate)
43+
intercalate, intersperse)
4444
import qualified Data.Map.Strict as Map
4545
import Data.Maybe (catMaybes, fromMaybe)
4646
import Data.String (IsString)
@@ -84,30 +84,41 @@ import qualified Development.IDE.GHC.Compat as SrcLoc
8484
import Development.IDE.Types.Options
8585
import DynamicLoading (initializePlugins)
8686
import FastString (unpackFS)
87-
import GHC (ExecOptions (execLineNumber, execSourceFile),
87+
import GHC (ClsInst,
88+
ExecOptions (execLineNumber, execSourceFile),
89+
FamInst, Fixity,
8890
GeneralFlag (..), Ghc,
8991
GhcLink (LinkInMemory),
9092
GhcMode (CompManager),
9193
GhcMonad (getSession),
9294
HscTarget (HscInterpreted),
9395
LoadHowMuch (LoadAllTargets),
9496
ModSummary (ms_hspp_opts),
97+
NamedThing (getName, getOccName),
9598
SuccessFlag (Failed, Succeeded),
9699
TcRnExprMode (..),
100+
TyThing, defaultFixity,
97101
execOptions, exprType,
102+
getInfo,
98103
getInteractiveDynFlags,
99104
getSessionDynFlags,
100105
isImport, isStmt, load,
101-
runDecls, setContext,
102-
setLogAction,
106+
parseName, pprFamInst,
107+
pprInstance, runDecls,
108+
setContext, setLogAction,
103109
setSessionDynFlags,
104110
setTargets, typeKind)
105111
import GhcPlugins (DynFlags (..),
106112
defaultLogActionHPutStrDoc,
107-
gopt_set, gopt_unset,
108-
hsc_dflags,
113+
elemNameSet, gopt_set,
114+
gopt_unset, hsc_dflags,
115+
isSymOcc, mkNameSet,
109116
parseDynamicFlagsCmdLine,
110-
targetPlatform, xopt_set)
117+
pprDefinedAt,
118+
pprInfixName,
119+
targetPlatform,
120+
tyThingParent_maybe,
121+
xopt_set)
111122
import HscTypes (InteractiveImport (IIModule),
112123
ModSummary (ms_mod),
113124
Target (Target),
@@ -132,8 +143,9 @@ import Language.LSP.Server
132143
import Language.LSP.Types
133144
import Language.LSP.Types.Lens (end, line)
134145
import Language.LSP.VFS (virtualFileText)
135-
import Outputable (nest, ppr, showSDoc,
136-
text, ($$), (<+>))
146+
import Outputable (SDoc, empty, hang, nest,
147+
ppr, showSDoc, text,
148+
vcat, ($$), (<+>))
137149
import System.FilePath (takeFileName)
138150
import System.IO (hClose)
139151
import UnliftIO.Temporary (withSystemTempFile)
@@ -146,6 +158,8 @@ import GHC.Parser.Annotation (ApiAnns (apiAnnComments))
146158
import GhcPlugins (interpWays, updateWays,
147159
wayGeneralFlags,
148160
wayUnsetGeneralFlags)
161+
import IfaceSyn (showToHeader)
162+
import PprTyThing (pprTyThingInContext)
149163
#endif
150164

151165
#if MIN_VERSION_ghc(9,0,0)
@@ -651,7 +665,12 @@ type GHCiLikeCmd = DynFlags -> Text -> Ghc (Maybe Text)
651665
-- Should we use some sort of trie here?
652666
ghciLikeCommands :: [(Text, GHCiLikeCmd)]
653667
ghciLikeCommands =
654-
[("kind", doKindCmd False), ("kind!", doKindCmd True), ("type", doTypeCmd)]
668+
[ ("info", doInfoCmd False)
669+
, ("info!", doInfoCmd True)
670+
, ("kind", doKindCmd False)
671+
, ("kind!", doKindCmd True)
672+
, ("type", doTypeCmd)
673+
]
655674

656675
evalGhciLikeCmd :: Text -> Text -> Ghc (Maybe [Text])
657676
evalGhciLikeCmd cmd arg = do
@@ -665,6 +684,51 @@ evalGhciLikeCmd cmd arg = do
665684
<$> hndler df arg
666685
_ -> E.throw $ GhciLikeCmdNotImplemented cmd arg
667686

687+
doInfoCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text)
688+
doInfoCmd allInfo dflags s = do
689+
sdocs <- mapM infoThing (T.words s)
690+
pure $ Just $ T.pack $ showSDoc dflags (vcat sdocs)
691+
where
692+
infoThing :: GHC.GhcMonad m => Text -> m SDoc
693+
infoThing (T.unpack -> str) = do
694+
names <- GHC.parseName str
695+
mb_stuffs <- mapM (GHC.getInfo allInfo) names
696+
let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)
697+
(catMaybes mb_stuffs)
698+
return $ vcat (intersperse (text "") $ map pprInfo filtered)
699+
700+
filterOutChildren :: (a -> TyThing) -> [a] -> [a]
701+
filterOutChildren get_thing xs
702+
= filter (not . has_parent) xs
703+
where
704+
all_names = mkNameSet (map (getName . get_thing) xs)
705+
has_parent x = case tyThingParent_maybe (get_thing x) of
706+
Just p -> getName p `elemNameSet` all_names
707+
Nothing -> False
708+
709+
pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc
710+
pprInfo (thing, fixity, cls_insts, fam_insts, docs)
711+
= docs
712+
$$ pprTyThingInContextLoc thing
713+
$$ showFixity thing fixity
714+
$$ vcat (map GHC.pprInstance cls_insts)
715+
$$ vcat (map GHC.pprFamInst fam_insts)
716+
717+
pprTyThingInContextLoc :: TyThing -> SDoc
718+
pprTyThingInContextLoc tyThing
719+
= showWithLoc (pprDefinedAt (getName tyThing))
720+
(pprTyThingInContext showToHeader tyThing)
721+
722+
showWithLoc :: SDoc -> SDoc -> SDoc
723+
showWithLoc loc doc
724+
= hang doc 2 (text "\t--" <+> loc)
725+
726+
showFixity :: TyThing -> Fixity -> SDoc
727+
showFixity thing fixity
728+
| fixity /= GHC.defaultFixity || isSymOcc (getOccName thing)
729+
= ppr fixity <+> pprInfixName (GHC.getName thing)
730+
| otherwise = empty
731+
668732
doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text)
669733
doKindCmd False df arg = do
670734
let input = T.strip arg

0 commit comments

Comments
 (0)