Show constraints on hover (#338)

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)

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)

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

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]

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 =

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"
   ]