Skip to content

Commit 0d9ba15

Browse files
akrmnakrmn
authored
Add :info command in Eval plugin (#1948)
* Add support for :info[!] command in Eval plugin * Add eval plugin info cmd tests
1 parent 6ffc6c5 commit 0d9ba15

File tree

13 files changed

+217
-22
lines changed

13 files changed

+217
-22
lines changed

‎plugins/hls-eval-plugin/hls-eval-plugin.cabal

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,9 @@ extra-source-files:
2323
test/testdata/*.hs
2424
test/testdata/*.lhs
2525
test/testdata/*.yaml
26-
test/testdata/cabal.project
26+
test/info-util/*.cabal
27+
test/info-util/*.hs
28+
test/cabal.project
2729

2830
flag pedantic
2931
description: Enable -Werror

‎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

‎plugins/hls-eval-plugin/test/Main.hs

Lines changed: 68 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,21 +1,22 @@
11
{-# LANGUAGE OverloadedStrings #-}
22
{-# LANGUAGE RecordWildCards #-}
3+
{-# LANGUAGE TypeApplications #-}
34
{-# LANGUAGE ViewPatterns #-}
45

56
module Main
67
( main
78
) where
89

9-
import Control.Lens (_Just, preview, view)
10-
import Control.Monad (when)
10+
import Control.Lens (_Just, preview, toListOf, view)
1111
import Data.Aeson (fromJSON)
1212
import Data.Aeson.Types (Result (Success))
13+
import Data.List (isInfixOf)
1314
import Data.List.Extra (nubOrdOn)
1415
import qualified Ide.Plugin.Eval as Eval
15-
import Ide.Plugin.Eval.Types (EvalParams (..))
16-
import Language.LSP.Types.Lens (command, range, title)
17-
import System.Directory (doesFileExist)
18-
import System.FilePath ((<.>), (</>))
16+
import Ide.Plugin.Eval.Types (EvalParams (..), Section (..),
17+
testOutput)
18+
import Language.LSP.Types.Lens (arguments, command, range, title)
19+
import System.FilePath ((</>))
1920
import Test.Hls
2021

2122
main :: IO ()
@@ -107,11 +108,56 @@ tests =
107108
]
108109
, goldenWithEval "Works with NoImplicitPrelude" "TNoImplicitPrelude" "hs"
109110
, goldenWithEval "Variable 'it' works" "TIt" "hs"
111+
112+
, testGroup ":info command"
113+
[ testCase ":info reports type, constructors and instances" $ do
114+
[output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfo.hs"
115+
"data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration"
116+
"Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo"
117+
"Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo"
118+
not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo"
119+
, testCase ":info reports type, constructors and instances for multiple types" $ do
120+
[output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfoMany.hs"
121+
"data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration"
122+
"Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo"
123+
"Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo"
124+
not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo"
125+
"data Bar = Bar1 | Bar2 | Bar3" `isInfixOf` output @? "Output does not include Bar data declaration"
126+
"Eq Bar" `isInfixOf` output @? "Output does not include instance Eq Bar"
127+
"Ord Bar" `isInfixOf` output @? "Output does not include instance Ord Bar"
128+
not ("Baz Bar" `isInfixOf` output) @? "Output includes instance Baz Bar"
129+
, testCase ":info! reports type, constructors and unfiltered instances" $ do
130+
[output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfoBang.hs"
131+
"data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration"
132+
"Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo"
133+
"Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo"
134+
"Baz Foo" `isInfixOf` output @? "Output does not include instance Baz Foo"
135+
, testCase ":info! reports type, constructors and unfiltered instances for multiple types" $ do
136+
[output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfoBangMany.hs"
137+
"data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration"
138+
"Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo"
139+
"Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo"
140+
"Baz Foo" `isInfixOf` output @? "Output does not include instance Baz Foo"
141+
"data Bar = Bar1 | Bar2 | Bar3" `isInfixOf` output @? "Output does not include Bar data declaration"
142+
"Eq Bar" `isInfixOf` output @? "Output does not include instance Eq Bar"
143+
"Ord Bar" `isInfixOf` output @? "Output does not include instance Ord Bar"
144+
"Baz Bar" `isInfixOf` output @? "Output does not include instance Baz Bar"
145+
, testCase ":i behaves exactly the same as :info" $ do
146+
[output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TI_Info.hs"
147+
"data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration"
148+
"Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo"
149+
"Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo"
150+
not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo"
151+
]
110152
]
111153

112154
goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree
113-
goldenWithEval title path ext = goldenWithHaskellDoc evalPlugin title testDataDir path "expected" ext $ \doc -> do
114-
-- Execute lenses backwards, to avoid affecting their position in the source file
155+
goldenWithEval title path ext =
156+
goldenWithHaskellDoc evalPlugin title testDataDir path "expected" ext executeLensesBackwards
157+
158+
-- | Execute lenses backwards, to avoid affecting their position in the source file
159+
executeLensesBackwards :: TextDocumentIdentifier -> Session ()
160+
executeLensesBackwards doc = do
115161
codeLenses <- reverse <$> getCodeLenses doc
116162
-- liftIO $ print codeLenses
117163

@@ -133,5 +179,19 @@ executeCmd cmd = do
133179
-- liftIO $ print _resp
134180
pure ()
135181

182+
evalLenses :: FilePath -> IO [CodeLens]
183+
evalLenses path = runSessionWithServer evalPlugin testDataDir $ do
184+
doc <- openDoc path "haskell"
185+
executeLensesBackwards doc
186+
getCodeLenses doc
187+
188+
codeLensTestOutput :: CodeLens -> [String]
189+
codeLensTestOutput codeLens = do
190+
CodeLens { _command = Just command } <- [codeLens]
191+
Command { _arguments = Just (List args) } <- [command]
192+
Success EvalParams { sections = sections } <- fromJSON @EvalParams <$> args
193+
Section { sectionTests = sectionTests } <- sections
194+
testOutput =<< sectionTests
195+
136196
testDataDir :: FilePath
137197
testDataDir = "test" </> "testdata"

‎plugins/hls-eval-plugin/test/cabal.project

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
packages:
2+
testdata/
3+
info-util/

‎plugins/hls-eval-plugin/test/info-util/InfoUtil.hs

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
module InfoUtil
2+
( Eq
3+
, Ord
4+
, Foo (..)
5+
, Bar (..)
6+
, Baz
7+
)
8+
where
9+
10+
import Prelude (Eq, Ord)
11+
12+
data Foo = Foo1 | Foo2
13+
deriving (Eq, Ord)
14+
15+
data Bar = Bar1 | Bar2 | Bar3
16+
deriving (Eq, Ord)
17+
18+
class Baz t
19+
instance Baz Foo
20+
instance Baz Bar

‎plugins/hls-eval-plugin/test/info-util/info-util.cabal

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
name: info-util
2+
version: 0.1.0.0
3+
-- synopsis:
4+
-- description:
5+
license: BSD3
6+
author: Author name here
7+
maintainer: [email protected]
8+
copyright: 2017 Author name here
9+
category: Web
10+
build-type: Simple
11+
cabal-version: >=1.10
12+
13+
library
14+
exposed-modules:
15+
InfoUtil
16+
build-depends: base >= 4.7 && < 5
17+
default-language: Haskell2010
18+
ghc-options: -Wall -fwarn-unused-imports

‎plugins/hls-eval-plugin/test/testdata/TI_Info.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
module TI_Info (Eq, Ord, Foo) where
2+
3+
import InfoUtil (Eq, Ord, Foo)
4+
5+
-- >>> :i Foo

‎plugins/hls-eval-plugin/test/testdata/TInfo.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
module TInfo (Eq, Ord, Foo) where
2+
3+
import InfoUtil (Eq, Ord, Foo)
4+
5+
-- >>> :info Foo

‎plugins/hls-eval-plugin/test/testdata/TInfoBang.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
module TInfoBang (Eq, Ord, Foo) where
2+
3+
import InfoUtil (Eq, Ord, Foo)
4+
5+
-- >>> :info! Foo

‎plugins/hls-eval-plugin/test/testdata/TInfoBangMany.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
module TInfoBangMany (Eq, Ord, Foo, Bar) where
2+
3+
import InfoUtil (Eq, Ord, Foo, Bar)
4+
5+
-- >>> :info! Foo Bar

‎plugins/hls-eval-plugin/test/testdata/TInfoMany.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
module TInfoMany (Eq, Ord, Foo, Bar) where
2+
3+
import InfoUtil (Eq, Ord, Foo, Bar)
4+
5+
-- >>> :info Foo Bar

‎plugins/hls-eval-plugin/test/testdata/cabal.project

Lines changed: 0 additions & 1 deletion
This file was deleted.

‎plugins/hls-eval-plugin/test/testdata/test.cabal

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -56,8 +56,12 @@ library
5656
TSetup
5757
Util
5858
TNested
59+
TInfo
60+
TInfoMany
61+
TInfoBang
62+
TInfoBangMany
63+
TI_Info
5964

60-
build-depends: base >= 4.7 && < 5, QuickCheck
65+
build-depends: base >= 4.7 && < 5, QuickCheck, info-util
6166
default-language: Haskell2010
6267
ghc-options: -Wall -fwarn-unused-imports
63-

0 commit comments

Comments
 (0)