Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Add :info command in Eval plugin #1948

Merged
merged 2 commits into from
Jun 21, 2021
Merged

Add :info command in Eval plugin #1948

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
366ce59
Add support for :info[!] command in Eval plugin
akrmn Jun 20, 2021
90cfb10
Add eval plugin info cmd tests
akrmn Jun 20, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 3 additions & 1 deletion plugins/hls-eval-plugin/hls-eval-plugin.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,9 @@ extra-source-files:
test/testdata/*.hs
test/testdata/*.lhs
test/testdata/*.yaml
test/testdata/cabal.project
test/info-util/*.cabal
test/info-util/*.hs
test/cabal.project

flag pedantic
description: Enable -Werror
Expand Down
84 changes: 74 additions & 10 deletions plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -40,7 +40,7 @@ import Data.Char (isSpace)
import qualified Data.DList as DL
import qualified Data.HashMap.Strict as HashMap
import Data.List (dropWhileEnd, find,
intercalate)
intercalate, intersperse)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromMaybe)
import Data.String (IsString)
Expand Down Expand Up @@ -84,30 +84,41 @@ import qualified Development.IDE.GHC.Compat as SrcLoc
import Development.IDE.Types.Options
import DynamicLoading (initializePlugins)
import FastString (unpackFS)
import GHC (ExecOptions (execLineNumber, execSourceFile),
import GHC (ClsInst,
ExecOptions (execLineNumber, execSourceFile),
FamInst, Fixity,
GeneralFlag (..), Ghc,
GhcLink (LinkInMemory),
GhcMode (CompManager),
GhcMonad (getSession),
HscTarget (HscInterpreted),
LoadHowMuch (LoadAllTargets),
ModSummary (ms_hspp_opts),
NamedThing (getName, getOccName),
SuccessFlag (Failed, Succeeded),
TcRnExprMode (..),
TyThing, defaultFixity,
execOptions, exprType,
getInfo,
getInteractiveDynFlags,
getSessionDynFlags,
isImport, isStmt, load,
runDecls, setContext,
setLogAction,
parseName, pprFamInst,
pprInstance, runDecls,
setContext, setLogAction,
setSessionDynFlags,
setTargets, typeKind)
import GhcPlugins (DynFlags (..),
defaultLogActionHPutStrDoc,
gopt_set, gopt_unset,
hsc_dflags,
elemNameSet, gopt_set,
gopt_unset, hsc_dflags,
isSymOcc, mkNameSet,
parseDynamicFlagsCmdLine,
targetPlatform, xopt_set)
pprDefinedAt,
pprInfixName,
targetPlatform,
tyThingParent_maybe,
xopt_set)
import HscTypes (InteractiveImport (IIModule),
ModSummary (ms_mod),
Target (Target),
Expand All @@ -132,8 +143,9 @@ import Language.LSP.Server
import Language.LSP.Types
import Language.LSP.Types.Lens (end, line)
import Language.LSP.VFS (virtualFileText)
import Outputable (nest, ppr, showSDoc,
text, ($$), (<+>))
import Outputable (SDoc, empty, hang, nest,
ppr, showSDoc, text,
vcat, ($$), (<+>))
import System.FilePath (takeFileName)
import System.IO (hClose)
import UnliftIO.Temporary (withSystemTempFile)
Expand All @@ -146,6 +158,8 @@ import GHC.Parser.Annotation (ApiAnns (apiAnnComments))
import GhcPlugins (interpWays, updateWays,
wayGeneralFlags,
wayUnsetGeneralFlags)
import IfaceSyn (showToHeader)
import PprTyThing (pprTyThingInContext)
#endif

#if MIN_VERSION_ghc(9,0,0)
Expand Down Expand Up @@ -651,7 +665,12 @@ type GHCiLikeCmd = DynFlags -> Text -> Ghc (Maybe Text)
-- Should we use some sort of trie here?
ghciLikeCommands :: [(Text, GHCiLikeCmd)]
ghciLikeCommands =
[("kind", doKindCmd False), ("kind!", doKindCmd True), ("type", doTypeCmd)]
[ ("info", doInfoCmd False)
, ("info!", doInfoCmd True)
, ("kind", doKindCmd False)
, ("kind!", doKindCmd True)
, ("type", doTypeCmd)
]

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

doInfoCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text)
doInfoCmd allInfo dflags s = do
sdocs <- mapM infoThing (T.words s)
pure $ Just $ T.pack $ showSDoc dflags (vcat sdocs)
where
infoThing :: GHC.GhcMonad m => Text -> m SDoc
infoThing (T.unpack -> str) = do
names <- GHC.parseName str
mb_stuffs <- mapM (GHC.getInfo allInfo) names
let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)
(catMaybes mb_stuffs)
return $ vcat (intersperse (text "") $ map pprInfo filtered)
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

You could always sort the filtered children before printing to ensure that the output is deterministic

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

yeah, the problem is the [ClsInst] part of the tuple returned by GHC.getInfo. Sadly, ClsInst doesn't have an Ord instance, and I didn't want to impose any custom ordering


filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren get_thing xs
= filter (not . has_parent) xs
where
all_names = mkNameSet (map (getName . get_thing) xs)
has_parent x = case tyThingParent_maybe (get_thing x) of
Just p -> getName p `elemNameSet` all_names
Nothing -> False

pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc
pprInfo (thing, fixity, cls_insts, fam_insts, docs)
= docs
$$ pprTyThingInContextLoc thing
$$ showFixity thing fixity
$$ vcat (map GHC.pprInstance cls_insts)
$$ vcat (map GHC.pprFamInst fam_insts)

pprTyThingInContextLoc :: TyThing -> SDoc
pprTyThingInContextLoc tyThing
= showWithLoc (pprDefinedAt (getName tyThing))
(pprTyThingInContext showToHeader tyThing)

showWithLoc :: SDoc -> SDoc -> SDoc
showWithLoc loc doc
= hang doc 2 (text "\t--" <+> loc)

showFixity :: TyThing -> Fixity -> SDoc
showFixity thing fixity
| fixity /= GHC.defaultFixity || isSymOcc (getOccName thing)
= ppr fixity <+> pprInfixName (GHC.getName thing)
| otherwise = empty

doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text)
doKindCmd False df arg = do
let input = T.strip arg
Expand Down
76 changes: 68 additions & 8 deletions plugins/hls-eval-plugin/test/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,21 +1,22 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

module Main
( main
) where

import Control.Lens (_Just, preview, view)
import Control.Monad (when)
import Control.Lens (_Just, preview, toListOf, view)
import Data.Aeson (fromJSON)
import Data.Aeson.Types (Result (Success))
import Data.List (isInfixOf)
import Data.List.Extra (nubOrdOn)
import qualified Ide.Plugin.Eval as Eval
import Ide.Plugin.Eval.Types (EvalParams (..))
import Language.LSP.Types.Lens (command, range, title)
import System.Directory (doesFileExist)
import System.FilePath ((<.>), (</>))
import Ide.Plugin.Eval.Types (EvalParams (..), Section (..),
testOutput)
import Language.LSP.Types.Lens (arguments, command, range, title)
import System.FilePath ((</>))
import Test.Hls

main :: IO ()
Expand Down Expand Up @@ -107,11 +108,56 @@ tests =
]
, goldenWithEval "Works with NoImplicitPrelude" "TNoImplicitPrelude" "hs"
, goldenWithEval "Variable 'it' works" "TIt" "hs"

, testGroup ":info command"
[ testCase ":info reports type, constructors and instances" $ do
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

As suggested by @jneira, these tests now only look for the relevant infix strings (or their absence)

[output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfo.hs"
"data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration"
"Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo"
"Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo"
not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo"
, testCase ":info reports type, constructors and instances for multiple types" $ do
[output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfoMany.hs"
"data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration"
"Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo"
"Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo"
not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo"
"data Bar = Bar1 | Bar2 | Bar3" `isInfixOf` output @? "Output does not include Bar data declaration"
"Eq Bar" `isInfixOf` output @? "Output does not include instance Eq Bar"
"Ord Bar" `isInfixOf` output @? "Output does not include instance Ord Bar"
not ("Baz Bar" `isInfixOf` output) @? "Output includes instance Baz Bar"
, testCase ":info! reports type, constructors and unfiltered instances" $ do
[output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfoBang.hs"
"data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration"
"Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo"
"Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo"
"Baz Foo" `isInfixOf` output @? "Output does not include instance Baz Foo"
, testCase ":info! reports type, constructors and unfiltered instances for multiple types" $ do
[output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfoBangMany.hs"
"data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration"
"Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo"
"Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo"
"Baz Foo" `isInfixOf` output @? "Output does not include instance Baz Foo"
"data Bar = Bar1 | Bar2 | Bar3" `isInfixOf` output @? "Output does not include Bar data declaration"
"Eq Bar" `isInfixOf` output @? "Output does not include instance Eq Bar"
"Ord Bar" `isInfixOf` output @? "Output does not include instance Ord Bar"
"Baz Bar" `isInfixOf` output @? "Output does not include instance Baz Bar"
, testCase ":i behaves exactly the same as :info" $ do
[output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TI_Info.hs"
"data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration"
"Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo"
"Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo"
not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo"
]
]

goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree
goldenWithEval title path ext = goldenWithHaskellDoc evalPlugin title testDataDir path "expected" ext $ \doc -> do
-- Execute lenses backwards, to avoid affecting their position in the source file
goldenWithEval title path ext =
goldenWithHaskellDoc evalPlugin title testDataDir path "expected" ext executeLensesBackwards

-- | Execute lenses backwards, to avoid affecting their position in the source file
executeLensesBackwards :: TextDocumentIdentifier -> Session ()
executeLensesBackwards doc = do
codeLenses <- reverse <$> getCodeLenses doc
-- liftIO $ print codeLenses

Expand All @@ -133,5 +179,19 @@ executeCmd cmd = do
-- liftIO $ print _resp
pure ()

evalLenses :: FilePath -> IO [CodeLens]
evalLenses path = runSessionWithServer evalPlugin testDataDir $ do
doc <- openDoc path "haskell"
executeLensesBackwards doc
getCodeLenses doc

codeLensTestOutput :: CodeLens -> [String]
codeLensTestOutput codeLens = do
CodeLens { _command = Just command } <- [codeLens]
Command { _arguments = Just (List args) } <- [command]
Success EvalParams { sections = sections } <- fromJSON @EvalParams <$> args
Section { sectionTests = sectionTests } <- sections
testOutput =<< sectionTests

testDataDir :: FilePath
testDataDir = "test" </> "testdata"
3 changes: 3 additions & 0 deletions plugins/hls-eval-plugin/test/cabal.project
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,3 @@
packages:
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I moved the test/testdata/cabal.project file one directory up, so I could define another library info-util. This was because :info prints the origin comment (-- defined in "...") using the full path to the file for modules in the same package, which wouldn't be portable.

testdata/
info-util/
20 changes: 20 additions & 0 deletions plugins/hls-eval-plugin/test/info-util/InfoUtil.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,20 @@
module InfoUtil
( Eq
, Ord
, Foo (..)
, Bar (..)
, Baz
)
where

import Prelude (Eq, Ord)

data Foo = Foo1 | Foo2
deriving (Eq, Ord)
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I ended up dropping the Show instances since they would still come out in different orders sometimes. Thankfully Eq, Ord and Baz are enough to show the difference between :info and :info!


data Bar = Bar1 | Bar2 | Bar3
deriving (Eq, Ord)

class Baz t
instance Baz Foo
instance Baz Bar
18 changes: 18 additions & 0 deletions plugins/hls-eval-plugin/test/info-util/info-util.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,18 @@
name: info-util
version: 0.1.0.0
-- synopsis:
-- description:
license: BSD3
author: Author name here
maintainer: example@example.com
copyright: 2017 Author name here
category: Web
build-type: Simple
cabal-version: >=1.10

library
exposed-modules:
InfoUtil
build-depends: base >= 4.7 && < 5
default-language: Haskell2010
ghc-options: -Wall -fwarn-unused-imports
5 changes: 5 additions & 0 deletions plugins/hls-eval-plugin/test/testdata/TI_Info.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
module TI_Info (Eq, Ord, Foo) where

import InfoUtil (Eq, Ord, Foo)

-- >>> :i Foo
5 changes: 5 additions & 0 deletions plugins/hls-eval-plugin/test/testdata/TInfo.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
module TInfo (Eq, Ord, Foo) where

import InfoUtil (Eq, Ord, Foo)

-- >>> :info Foo
5 changes: 5 additions & 0 deletions plugins/hls-eval-plugin/test/testdata/TInfoBang.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
module TInfoBang (Eq, Ord, Foo) where

import InfoUtil (Eq, Ord, Foo)

-- >>> :info! Foo
5 changes: 5 additions & 0 deletions plugins/hls-eval-plugin/test/testdata/TInfoBangMany.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
module TInfoBangMany (Eq, Ord, Foo, Bar) where

import InfoUtil (Eq, Ord, Foo, Bar)

-- >>> :info! Foo Bar
5 changes: 5 additions & 0 deletions plugins/hls-eval-plugin/test/testdata/TInfoMany.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
module TInfoMany (Eq, Ord, Foo, Bar) where

import InfoUtil (Eq, Ord, Foo, Bar)

-- >>> :info Foo Bar
1 change: 0 additions & 1 deletion plugins/hls-eval-plugin/test/testdata/cabal.project
View file
Open in desktop

This file was deleted.

8 changes: 6 additions & 2 deletions plugins/hls-eval-plugin/test/testdata/test.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -56,8 +56,12 @@ library
TSetup
Util
TNested
TInfo
TInfoMany
TInfoBang
TInfoBangMany
TI_Info

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