Add :info command in Eval plugin

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

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,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),
@@ -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

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"

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

@@ -0,0 +1,3 @@
+packages:
+  testdata/
+  info-util/

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

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:          [email protected]
+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

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

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

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

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

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

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
-