2154bb2 · ghcide · git.iko.soy

src/Development/IDE/Core/RuleTypes.hs+1−1

compare with master

unifiedsplit

@@ -63,7 +63,7 @@ instance NFData TcModuleResult where

63type instance RuleResult TypeCheck = TcModuleResult

64

65-- | Information about what spans occur where, requires TypeCheck

66−type instance RuleResult GetSpanInfo = [SpanInfo]

66+type instance RuleResult GetSpanInfo = SpansInfo

67

68-- | Convert to Core, requires TypeCheck*

69type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)

src/Development/IDE/Core/Rules.hs+2−1

@@ -54,6 +54,7 @@ import qualified Data.Text as T

54import Development.IDE.GHC.Error

55import Development.Shake hiding (Diagnostic)

56import Development.IDE.Core.RuleTypes

57+import Development.IDE.Spans.Type

57

58

58import GHC hiding (parseModule, typecheckModule)

59import GHC hiding (parseModule, typecheckModule)

59import qualified GHC.LanguageExtensions as LangExt

60import qualified GHC.LanguageExtensions as LangExt

@@ -114,7 +115,7 @@ getDefinition file pos = fmap join $ runMaybeT $ do

114 spans <- useE GetSpanInfo file

115 spans <- useE GetSpanInfo file

115 pkgState <- hscEnv <$> useE GhcSession file

116 pkgState <- hscEnv <$> useE GhcSession file

116 let getHieFile x = useNoFile (GetHieFile x)

117 let getHieFile x = useNoFile (GetHieFile x)

117− lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos

118+ lift $ AtPoint.gotoDefinition getHieFile opts pkgState (spansExprs spans) pos

118

119

119-- | Parse the contents of a daml file.

120-- | Parse the contents of a daml file.

120getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)

121getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)

src/Development/IDE/Spans/AtPoint.hs+17−6

@@ -27,6 +27,8 @@ import FastString

27import Name

28import Outputable hiding ((<>))

29import SrcLoc

30+import Type

31+import VarSet

30

32

31import Control.Monad.Extra

33import Control.Monad.Extra

32import Control.Monad.Trans.Maybe

34import Control.Monad.Trans.Maybe

@@ -50,15 +52,16 @@ gotoDefinition getHieFile ideOpts pkgState srcSpans pos =

50-- | Synopsis for the name at a given position.

52-- | Synopsis for the name at a given position.

51atPoint

53atPoint

52 :: IdeOptions

54 :: IdeOptions

53− -> [SpanInfo]

55+ -> SpansInfo

54 -> Position

56 -> Position

55 -> Maybe (Maybe Range, [T.Text])

57 -> Maybe (Maybe Range, [T.Text])

56−atPoint IdeOptions{..} srcSpans pos = do

58+atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do

57 firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans

59 firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans

60+ let constraintsAtPoint = mapMaybe spaninfoType (spansAtPoint pos cntsSpans)

58− return (Just (range firstSpan), hoverInfo firstSpan)

61+ return (Just (range firstSpan), hoverInfo firstSpan constraintsAtPoint)

59 where

62 where

60 -- Hover info for types, classes, type variables

63 -- Hover info for types, classes, type variables

61− hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs , ..} =

64+ hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs , ..} _ =

62 (wrapLanguageSyntax <$> name) <> location <> spanDocToMarkdown docs

65 (wrapLanguageSyntax <$> name) <> location <> spanDocToMarkdown docs

63 where

66 where

64 name = [maybe shouldNotHappen showName mbName]

67 name = [maybe shouldNotHappen showName mbName]

@@ -67,11 +70,10 @@ atPoint IdeOptions{..} srcSpans pos = do

67 mbName = getNameM spaninfoSource

70 mbName = getNameM spaninfoSource

68

71

69 -- Hover info for values/data

72 -- Hover info for values/data

70− hoverInfo SpanInfo{spaninfoType = (Just typ), spaninfoDocs = docs , ..} =

73+ hoverInfo SpanInfo{spaninfoType = (Just typ), spaninfoDocs = docs , ..} cnts =

71 (wrapLanguageSyntax <$> nameOrSource) <> location <> spanDocToMarkdown docs

74 (wrapLanguageSyntax <$> nameOrSource) <> location <> spanDocToMarkdown docs

72 where

75 where

73 mbName = getNameM spaninfoSource

76 mbName = getNameM spaninfoSource

74− typeAnnotation = colon <> showName typ

75 expr = case spaninfoSource of

77 expr = case spaninfoSource of

76 Named n -> qualifyNameIfPossible n

78 Named n -> qualifyNameIfPossible n

77 Lit l -> crop $ T.pack l

79 Lit l -> crop $ T.pack l

@@ -81,6 +83,15 @@ atPoint IdeOptions{..} srcSpans pos = do

81 where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')

83 where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')

82 location = [maybe "" definedAt mbName]

84 location = [maybe "" definedAt mbName]

83

85

86+ thisFVs = tyCoVarsOfType typ

87+ constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts

88+ constraintsT = T.intercalate ", " (map showName constraintsOverFVs)

89+

90+ typeAnnotation = case constraintsOverFVs of

91+ [] -> colon <> showName typ

92+ [_] -> colon <> constraintsT <> "\n=> " <> showName typ

93+ _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ

94+

84 definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*\n"

95 definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*\n"

85

96

86 crop txt

97 crop txt

src/Development/IDE/Spans/Calculate.hs+13−3

@@ -52,7 +52,7 @@ getSrcSpanInfos

52 -> [(Located ModuleName, Maybe NormalizedFilePath)]

53 -> TcModuleResult

54 -> [TcModuleResult]

55− -> IO [SpanInfo]

55+ -> IO SpansInfo

56getSrcSpanInfos env imports tc tms =

57 runGhcEnv env $

58 getSpanInfo imports (tmrModule tc) (map tmrModule tms)

@@ -62,7 +62,7 @@ getSpanInfo :: GhcMonad m

62 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports

63 -> TypecheckedModule

64 -> [TypecheckedModule]

65− -> m [SpanInfo]

65+ -> m SpansInfo

66getSpanInfo mods tcm tcms =

67 do let tcs = tm_typechecked_source tcm

68 bs = listifyAllSpans tcs :: [LHsBind GhcTc]

@@ -78,13 +78,16 @@ getSpanInfo mods tcm tcms =

78 let imports = importInfo mods

79 let exports = getExports tcm

80 let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)

81+ let constraints = map constraintToInfo (concatMap getConstraintsLHsBind bs)

81− return (mapMaybe toSpanInfo (sortBy cmp exprs))

82+ return $ SpansInfo (mapMaybe toSpanInfo (sortBy cmp exprs))

83+ (mapMaybe toSpanInfo (sortBy cmp constraints))

82 where cmp (_,a,_,_) (_,b,_,_)

84 where cmp (_,a,_,_) (_,b,_,_)

83 | a `isSubspanOf` b = LT

85 | a `isSubspanOf` b = LT

84 | b `isSubspanOf` a = GT

86 | b `isSubspanOf` a = GT

85 | otherwise = compare (srcSpanStart a) (srcSpanStart b)

87 | otherwise = compare (srcSpanStart a) (srcSpanStart b)

86

88

87 addEmptyInfo = map (\(a,b) -> (a,b,Nothing,emptySpanDoc))

89 addEmptyInfo = map (\(a,b) -> (a,b,Nothing,emptySpanDoc))

90+ constraintToInfo (sp, ty) = (SpanS sp, sp, Just ty, emptySpanDoc)

88

91

89-- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always

92-- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always

90-- points to the first match) whereas the parsed module has the correct locations.

93-- 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

130 return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)]

133 return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)]

131getTypeLHsBind _ _ _ = return []

134getTypeLHsBind _ _ _ = return []

132

135

136+-- | Get information about constraints

137+getConstraintsLHsBind :: LHsBind GhcTc

138+ -> [(SrcSpan, Type)]

139+getConstraintsLHsBind (L spn AbsBinds { abs_ev_vars = vars })

140+ = map (\v -> (spn, varType v)) vars

141+getConstraintsLHsBind _ = []

142+

133-- | Get the name and type of an expression.

143-- | Get the name and type of an expression.

134getTypeLHsExpr :: (GhcMonad m)

144getTypeLHsExpr :: (GhcMonad m)

135 => [TypecheckedModule]

145 => [TypecheckedModule]

src/Development/IDE/Spans/Type.hs+10−1

@@ -6,7 +6,8 @@

6-- | Types used separate to GHCi vanilla.

7

8module Development.IDE.Spans.Type(

9+ SpansInfo(..)

9− SpanInfo(..)

10+ , SpanInfo(..)

10 , SpanSource(..)

11 , SpanSource(..)

11 , getNameM

12 , getNameM

12 ) where

13 ) where

@@ -17,6 +18,14 @@ import OccName

17import Development.IDE.GHC.Util

18import Development.IDE.GHC.Util

18import Development.IDE.Spans.Common

19import Development.IDE.Spans.Common

19

20

21+data SpansInfo =

22+ SpansInfo { spansExprs :: [SpanInfo]

23+ , spansConstraints :: [SpanInfo] }

24+ deriving Show

25+

26+instance NFData SpansInfo where

27+ rnf (SpansInfo e c) = liftRnf rnf e `seq` liftRnf rnf c

28+

20-- | Type of some span of source code. Most of these fields are

29-- | Type of some span of source code. Most of these fields are

21-- unboxed but Haddock doesn't show that.

30-- unboxed but Haddock doesn't show that.

22data SpanInfo =

31data SpanInfo =

test/exe/Main.hs+2−2

@@ -1146,7 +1146,7 @@ findDefinitionAndHoverTests = let

1146 mclL37 = Position 37 1

1147 spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]

1148 docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]

1149− ; constr = [ExpectHoverText ["Monad m =>"]]

1149+ ; constr = [ExpectHoverText ["Monad m"]]

1150 eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]

1151 intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]

1152 tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]

@@ -1191,7 +1191,7 @@ findDefinitionAndHoverTests = let

1191 , test no yes chrL36 litC "literal Char in hover info #274"

1192 , test no broken txtL8 litT "literal Text in hover info #274"

1193 , test no broken lstL43 litL "literal List in hover info #274"

1194− , test no broken docL41 constr "type constraint in hover info #283"

1194+ , test no yes docL41 constr "type constraint in hover info #283"

1195 , test broken broken outL45 outSig "top-level signature #310"

1196 , test broken broken innL48 innSig "inner signature #310"

1197 ]