From 2154bb2eafbb021d169cd85a47d7558c4db28328 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Wed, 22 Jan 2020 10:40:26 +0100 Subject: [PATCH] Show constraints on hover (#338) --- src/Development/IDE/Core/RuleTypes.hs | 2 +- src/Development/IDE/Core/Rules.hs | 3 ++- src/Development/IDE/Spans/AtPoint.hs | 23 +++++++++++++++++------ src/Development/IDE/Spans/Calculate.hs | 16 +++++++++++++--- src/Development/IDE/Spans/Type.hs | 11 ++++++++++- test/exe/Main.hs | 4 ++-- 6 files changed, 45 insertions(+), 14 deletions(-) diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs index 77903e70f5..1431f115f6 100644 --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -63,7 +63,7 @@ instance NFData TcModuleResult where type instance RuleResult TypeCheck = TcModuleResult -- | Information about what spans occur where, requires TypeCheck -type instance RuleResult GetSpanInfo = [SpanInfo] +type instance RuleResult GetSpanInfo = SpansInfo -- | Convert to Core, requires TypeCheck* type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails) diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs index 9a935d58dd..f2e5c368ec 100644 --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -54,6 +54,7 @@ import qualified Data.Text as T import Development.IDE.GHC.Error import Development.Shake hiding (Diagnostic) import Development.IDE.Core.RuleTypes +import Development.IDE.Spans.Type import GHC hiding (parseModule, typecheckModule) import qualified GHC.LanguageExtensions as LangExt @@ -114,7 +115,7 @@ getDefinition file pos = fmap join $ runMaybeT $ do spans <- useE GetSpanInfo file pkgState <- hscEnv <$> useE GhcSession file let getHieFile x = useNoFile (GetHieFile x) - lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos + lift $ AtPoint.gotoDefinition getHieFile opts pkgState (spansExprs spans) pos -- | Parse the contents of a daml file. getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule) diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs index e8faadb95c..64717c51eb 100644 --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -27,6 +27,8 @@ import FastString import Name import Outputable hiding ((<>)) import SrcLoc +import Type +import VarSet import Control.Monad.Extra import Control.Monad.Trans.Maybe @@ -50,15 +52,16 @@ gotoDefinition getHieFile ideOpts pkgState srcSpans pos = -- | Synopsis for the name at a given position. atPoint :: IdeOptions - -> [SpanInfo] + -> SpansInfo -> Position -> Maybe (Maybe Range, [T.Text]) -atPoint IdeOptions{..} srcSpans pos = do +atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans - return (Just (range firstSpan), hoverInfo firstSpan) + let constraintsAtPoint = mapMaybe spaninfoType (spansAtPoint pos cntsSpans) + return (Just (range firstSpan), hoverInfo firstSpan constraintsAtPoint) where -- Hover info for types, classes, type variables - hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs , ..} = + hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs , ..} _ = (wrapLanguageSyntax <$> name) <> location <> spanDocToMarkdown docs where name = [maybe shouldNotHappen showName mbName] @@ -67,11 +70,10 @@ atPoint IdeOptions{..} srcSpans pos = do mbName = getNameM spaninfoSource -- Hover info for values/data - hoverInfo SpanInfo{spaninfoType = (Just typ), spaninfoDocs = docs , ..} = + hoverInfo SpanInfo{spaninfoType = (Just typ), spaninfoDocs = docs , ..} cnts = (wrapLanguageSyntax <$> nameOrSource) <> location <> spanDocToMarkdown docs where mbName = getNameM spaninfoSource - typeAnnotation = colon <> showName typ expr = case spaninfoSource of Named n -> qualifyNameIfPossible n Lit l -> crop $ T.pack l @@ -81,6 +83,15 @@ atPoint IdeOptions{..} srcSpans pos = do where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name') location = [maybe "" definedAt mbName] + thisFVs = tyCoVarsOfType typ + constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts + constraintsT = T.intercalate ", " (map showName constraintsOverFVs) + + typeAnnotation = case constraintsOverFVs of + [] -> colon <> showName typ + [_] -> colon <> constraintsT <> "\n=> " <> showName typ + _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ + definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*\n" crop txt diff --git a/src/Development/IDE/Spans/Calculate.hs b/src/Development/IDE/Spans/Calculate.hs index ed83923e55..5237595517 100644 --- a/src/Development/IDE/Spans/Calculate.hs +++ b/src/Development/IDE/Spans/Calculate.hs @@ -52,7 +52,7 @@ getSrcSpanInfos -> [(Located ModuleName, Maybe NormalizedFilePath)] -> TcModuleResult -> [TcModuleResult] - -> IO [SpanInfo] + -> IO SpansInfo getSrcSpanInfos env imports tc tms = runGhcEnv env $ getSpanInfo imports (tmrModule tc) (map tmrModule tms) @@ -62,7 +62,7 @@ getSpanInfo :: GhcMonad m => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports -> TypecheckedModule -> [TypecheckedModule] - -> m [SpanInfo] + -> m SpansInfo getSpanInfo mods tcm tcms = do let tcs = tm_typechecked_source tcm bs = listifyAllSpans tcs :: [LHsBind GhcTc] @@ -78,13 +78,16 @@ getSpanInfo mods tcm tcms = let imports = importInfo mods let exports = getExports tcm let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts) - return (mapMaybe toSpanInfo (sortBy cmp exprs)) + let constraints = map constraintToInfo (concatMap getConstraintsLHsBind bs) + return $ SpansInfo (mapMaybe toSpanInfo (sortBy cmp exprs)) + (mapMaybe toSpanInfo (sortBy cmp constraints)) where cmp (_,a,_,_) (_,b,_,_) | a `isSubspanOf` b = LT | b `isSubspanOf` a = GT | otherwise = compare (srcSpanStart a) (srcSpanStart b) addEmptyInfo = map (\(a,b) -> (a,b,Nothing,emptySpanDoc)) + constraintToInfo (sp, ty) = (SpanS sp, sp, Just ty, emptySpanDoc) -- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always -- points to the first match) whereas the parsed module has the correct locations. @@ -130,6 +133,13 @@ getTypeLHsBind tms _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)] getTypeLHsBind _ _ _ = return [] +-- | Get information about constraints +getConstraintsLHsBind :: LHsBind GhcTc + -> [(SrcSpan, Type)] +getConstraintsLHsBind (L spn AbsBinds { abs_ev_vars = vars }) + = map (\v -> (spn, varType v)) vars +getConstraintsLHsBind _ = [] + -- | Get the name and type of an expression. getTypeLHsExpr :: (GhcMonad m) => [TypecheckedModule] diff --git a/src/Development/IDE/Spans/Type.hs b/src/Development/IDE/Spans/Type.hs index 1823666bc2..635cd1fd6d 100644 --- a/src/Development/IDE/Spans/Type.hs +++ b/src/Development/IDE/Spans/Type.hs @@ -6,7 +6,8 @@ -- | Types used separate to GHCi vanilla. module Development.IDE.Spans.Type( - SpanInfo(..) + SpansInfo(..) + , SpanInfo(..) , SpanSource(..) , getNameM ) where @@ -17,6 +18,14 @@ import OccName import Development.IDE.GHC.Util import Development.IDE.Spans.Common +data SpansInfo = + SpansInfo { spansExprs :: [SpanInfo] + , spansConstraints :: [SpanInfo] } + deriving Show + +instance NFData SpansInfo where + rnf (SpansInfo e c) = liftRnf rnf e `seq` liftRnf rnf c + -- | Type of some span of source code. Most of these fields are -- unboxed but Haddock doesn't show that. data SpanInfo = diff --git a/test/exe/Main.hs b/test/exe/Main.hs index 63851e9a6f..f3647f6858 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -1146,7 +1146,7 @@ findDefinitionAndHoverTests = let mclL37 = Position 37 1 spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] - ; constr = [ExpectHoverText ["Monad m =>"]] + ; constr = [ExpectHoverText ["Monad m"]] eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]] intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]] tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]] @@ -1191,7 +1191,7 @@ findDefinitionAndHoverTests = let , test no yes chrL36 litC "literal Char in hover info #274" , test no broken txtL8 litT "literal Text in hover info #274" , test no broken lstL43 litL "literal List in hover info #274" - , test no broken docL41 constr "type constraint in hover info #283" + , test no yes docL41 constr "type constraint in hover info #283" , test broken broken outL45 outSig "top-level signature #310" , test broken broken innL48 innSig "inner signature #310" ]