@@ -40,7 +40,7 @@ import Data.Char (isSpace)
40
40
import qualified Data.DList as DL
41
41
import qualified Data.HashMap.Strict as HashMap
42
42
import Data.List (dropWhileEnd , find ,
43
- intercalate )
43
+ intercalate , intersperse )
44
44
import qualified Data.Map.Strict as Map
45
45
import Data.Maybe (catMaybes , fromMaybe )
46
46
import Data.String (IsString )
@@ -84,30 +84,41 @@ import qualified Development.IDE.GHC.Compat as SrcLoc
84
84
import Development.IDE.Types.Options
85
85
import DynamicLoading (initializePlugins )
86
86
import FastString (unpackFS )
87
- import GHC (ExecOptions (execLineNumber , execSourceFile ),
87
+ import GHC (ClsInst ,
88
+ ExecOptions (execLineNumber , execSourceFile ),
89
+ FamInst , Fixity ,
88
90
GeneralFlag (.. ), Ghc ,
89
91
GhcLink (LinkInMemory ),
90
92
GhcMode (CompManager ),
91
93
GhcMonad (getSession ),
92
94
HscTarget (HscInterpreted ),
93
95
LoadHowMuch (LoadAllTargets ),
94
96
ModSummary (ms_hspp_opts ),
97
+ NamedThing (getName , getOccName ),
95
98
SuccessFlag (Failed , Succeeded ),
96
99
TcRnExprMode (.. ),
100
+ TyThing , defaultFixity ,
97
101
execOptions , exprType ,
102
+ getInfo ,
98
103
getInteractiveDynFlags ,
99
104
getSessionDynFlags ,
100
105
isImport , isStmt , load ,
101
- runDecls , setContext ,
102
- setLogAction ,
106
+ parseName , pprFamInst ,
107
+ pprInstance , runDecls ,
108
+ setContext , setLogAction ,
103
109
setSessionDynFlags ,
104
110
setTargets , typeKind )
105
111
import GhcPlugins (DynFlags (.. ),
106
112
defaultLogActionHPutStrDoc ,
107
- gopt_set , gopt_unset ,
108
- hsc_dflags ,
113
+ elemNameSet , gopt_set ,
114
+ gopt_unset , hsc_dflags ,
115
+ isSymOcc , mkNameSet ,
109
116
parseDynamicFlagsCmdLine ,
110
- targetPlatform , xopt_set )
117
+ pprDefinedAt ,
118
+ pprInfixName ,
119
+ targetPlatform ,
120
+ tyThingParent_maybe ,
121
+ xopt_set )
111
122
import HscTypes (InteractiveImport (IIModule ),
112
123
ModSummary (ms_mod ),
113
124
Target (Target ),
@@ -132,8 +143,9 @@ import Language.LSP.Server
132
143
import Language.LSP.Types
133
144
import Language.LSP.Types.Lens (end , line )
134
145
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 , ($$) , (<+>) )
137
149
import System.FilePath (takeFileName )
138
150
import System.IO (hClose )
139
151
import UnliftIO.Temporary (withSystemTempFile )
@@ -146,6 +158,8 @@ import GHC.Parser.Annotation (ApiAnns (apiAnnComments))
146
158
import GhcPlugins (interpWays , updateWays ,
147
159
wayGeneralFlags ,
148
160
wayUnsetGeneralFlags )
161
+ import IfaceSyn (showToHeader )
162
+ import PprTyThing (pprTyThingInContext )
149
163
#endif
150
164
151
165
#if MIN_VERSION_ghc(9,0,0)
@@ -651,7 +665,12 @@ type GHCiLikeCmd = DynFlags -> Text -> Ghc (Maybe Text)
651
665
-- Should we use some sort of trie here?
652
666
ghciLikeCommands :: [(Text , GHCiLikeCmd )]
653
667
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
+ ]
655
674
656
675
evalGhciLikeCmd :: Text -> Text -> Ghc (Maybe [Text ])
657
676
evalGhciLikeCmd cmd arg = do
@@ -665,6 +684,51 @@ evalGhciLikeCmd cmd arg = do
665
684
<$> hndler df arg
666
685
_ -> E. throw $ GhciLikeCmdNotImplemented cmd arg
667
686
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
+
668
732
doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text )
669
733
doKindCmd False df arg = do
670
734
let input = T. strip arg
0 commit comments