diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 908c369a0d..ff901f7bef 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -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 diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index b0602a3583..ad97feb6ea 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -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) @@ -84,7 +84,9 @@ 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), @@ -92,22 +94,31 @@ import GHC (ExecOptions (execLineNumb 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), @@ -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) @@ -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) @@ -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 @@ -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) + + 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 diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index eb7912e694..ff684a7281 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -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 () @@ -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 + [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 @@ -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" diff --git a/plugins/hls-eval-plugin/test/cabal.project b/plugins/hls-eval-plugin/test/cabal.project new file mode 100644 index 0000000000..f0e29ace6b --- /dev/null +++ b/plugins/hls-eval-plugin/test/cabal.project @@ -0,0 +1,3 @@ +packages: + testdata/ + info-util/ diff --git a/plugins/hls-eval-plugin/test/info-util/InfoUtil.hs b/plugins/hls-eval-plugin/test/info-util/InfoUtil.hs new file mode 100644 index 0000000000..2477bfce1a --- /dev/null +++ b/plugins/hls-eval-plugin/test/info-util/InfoUtil.hs @@ -0,0 +1,20 @@ +module InfoUtil + ( Eq + , Ord + , Foo (..) + , Bar (..) + , Baz + ) +where + +import Prelude (Eq, Ord) + +data Foo = Foo1 | Foo2 + deriving (Eq, Ord) + +data Bar = Bar1 | Bar2 | Bar3 + deriving (Eq, Ord) + +class Baz t +instance Baz Foo +instance Baz Bar diff --git a/plugins/hls-eval-plugin/test/info-util/info-util.cabal b/plugins/hls-eval-plugin/test/info-util/info-util.cabal new file mode 100644 index 0000000000..8c766a58c4 --- /dev/null +++ b/plugins/hls-eval-plugin/test/info-util/info-util.cabal @@ -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 diff --git a/plugins/hls-eval-plugin/test/testdata/TI_Info.hs b/plugins/hls-eval-plugin/test/testdata/TI_Info.hs new file mode 100644 index 0000000000..931ab2d7c4 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TI_Info.hs @@ -0,0 +1,5 @@ +module TI_Info (Eq, Ord, Foo) where + +import InfoUtil (Eq, Ord, Foo) + +-- >>> :i Foo diff --git a/plugins/hls-eval-plugin/test/testdata/TInfo.hs b/plugins/hls-eval-plugin/test/testdata/TInfo.hs new file mode 100644 index 0000000000..5562ff8d6a --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TInfo.hs @@ -0,0 +1,5 @@ +module TInfo (Eq, Ord, Foo) where + +import InfoUtil (Eq, Ord, Foo) + +-- >>> :info Foo diff --git a/plugins/hls-eval-plugin/test/testdata/TInfoBang.hs b/plugins/hls-eval-plugin/test/testdata/TInfoBang.hs new file mode 100644 index 0000000000..dae2550716 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TInfoBang.hs @@ -0,0 +1,5 @@ +module TInfoBang (Eq, Ord, Foo) where + +import InfoUtil (Eq, Ord, Foo) + +-- >>> :info! Foo diff --git a/plugins/hls-eval-plugin/test/testdata/TInfoBangMany.hs b/plugins/hls-eval-plugin/test/testdata/TInfoBangMany.hs new file mode 100644 index 0000000000..b547960a5b --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TInfoBangMany.hs @@ -0,0 +1,5 @@ +module TInfoBangMany (Eq, Ord, Foo, Bar) where + +import InfoUtil (Eq, Ord, Foo, Bar) + +-- >>> :info! Foo Bar diff --git a/plugins/hls-eval-plugin/test/testdata/TInfoMany.hs b/plugins/hls-eval-plugin/test/testdata/TInfoMany.hs new file mode 100644 index 0000000000..39d7da6fa4 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TInfoMany.hs @@ -0,0 +1,5 @@ +module TInfoMany (Eq, Ord, Foo, Bar) where + +import InfoUtil (Eq, Ord, Foo, Bar) + +-- >>> :info Foo Bar diff --git a/plugins/hls-eval-plugin/test/testdata/cabal.project b/plugins/hls-eval-plugin/test/testdata/cabal.project deleted file mode 100644 index 6f920794c8..0000000000 --- a/plugins/hls-eval-plugin/test/testdata/cabal.project +++ /dev/null @@ -1 +0,0 @@ -packages: ./ diff --git a/plugins/hls-eval-plugin/test/testdata/test.cabal b/plugins/hls-eval-plugin/test/testdata/test.cabal index 16054eca22..e3845f75f2 100644 --- a/plugins/hls-eval-plugin/test/testdata/test.cabal +++ b/plugins/hls-eval-plugin/test/testdata/test.cabal @@ -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 -