Skip to content

Commit 0807587

Browse files
pepeiborrapepeiborra
committed
extract GetEvalComments rule
1 parent 676a3a3 commit 0807587

File tree

5 files changed

+175
-145
lines changed

5 files changed

+175
-145
lines changed

‎plugins/hls-eval-plugin/hls-eval-plugin.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,7 @@ library
4848
Ide.Plugin.Eval.GHC
4949
Ide.Plugin.Eval.Parse.Comments
5050
Ide.Plugin.Eval.Parse.Option
51+
Ide.Plugin.Eval.Rules
5152
Ide.Plugin.Eval.Util
5253

5354
build-depends:
@@ -65,6 +66,7 @@ library
6566
, ghc-paths
6667
, ghcide >=1.2 && <1.5
6768
, hashable
69+
, hls-graph
6870
, hls-plugin-api ^>=1.2
6971
, lens
7072
, lsp

‎plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ module Ide.Plugin.Eval (
1111

1212
import Development.IDE (IdeState)
1313
import qualified Ide.Plugin.Eval.CodeLens as CL
14+
import Ide.Plugin.Eval.Rules (rules)
1415
import Ide.Types (PluginDescriptor (..), PluginId,
1516
defaultPluginDescriptor,
1617
mkPluginHandler)
@@ -22,4 +23,5 @@ descriptor plId =
2223
(defaultPluginDescriptor plId)
2324
{ pluginHandlers = mkPluginHandler STextDocumentCodeLens CL.codeLens
2425
, pluginCommands = [CL.evalCommand]
26+
, pluginRules = rules
2527
}

‎plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs

Lines changed: 87 additions & 135 deletions
Original file line numberDiff line numberDiff line change
@@ -25,121 +25,93 @@ module Ide.Plugin.Eval.CodeLens (
2525
evalCommand,
2626
) where
2727

28-
import Control.Applicative (Alternative ((<|>)))
29-
import Control.Arrow (second, (>>>))
30-
import Control.Exception (try)
31-
import qualified Control.Exception as E
32-
import Control.Lens (_1, _3, (%~), (<&>),
33-
(^.))
34-
import Control.Monad (guard, join, void, when)
35-
import Control.Monad.IO.Class (MonadIO (liftIO))
36-
import Control.Monad.Trans.Except (ExceptT (..))
37-
import Data.Aeson (toJSON)
38-
import Data.Char (isSpace)
39-
import qualified Data.DList as DL
40-
import qualified Data.HashMap.Strict as HashMap
41-
import Data.List (dropWhileEnd, find,
42-
intercalate, intersperse)
43-
import qualified Data.Map.Strict as Map
44-
import Data.Maybe (catMaybes, fromMaybe)
45-
import Data.String (IsString)
46-
import Data.Text (Text)
47-
import qualified Data.Text as T
48-
import Data.Time (getCurrentTime)
49-
import Data.Typeable (Typeable)
50-
import Development.IDE (Action,
51-
GetDependencies (..),
52-
GetModIface (..),
53-
GetModSummary (..),
54-
GetParsedModuleWithComments (..),
55-
GhcSessionIO (..),
56-
HiFileResult (hirHomeMod, hirModSummary),
57-
HscEnvEq, IdeState,
58-
ModSummaryResult (..),
59-
evalGhcEnv,
60-
hscEnvWithImportPaths,
61-
prettyPrint,
62-
realSrcSpanToRange,
63-
runAction,
64-
textToStringBuffer,
65-
toNormalizedFilePath',
66-
uriToFilePath',
67-
useNoFile_,
68-
useWithStale_, use_,
69-
uses_)
70-
import Development.IDE.Core.Compile (loadModulesHome,
71-
setupFinderCache)
72-
import Development.IDE.Core.PositionMapping (toCurrentRange)
73-
import Development.IDE.Core.Rules (TransitiveDependencies (transitiveModuleDeps))
74-
import Development.IDE.GHC.Compat hiding (typeKind,
75-
unitState)
76-
import qualified Development.IDE.GHC.Compat as Compat
77-
import qualified Development.IDE.GHC.Compat as SrcLoc
78-
import Development.IDE.GHC.Compat.Util (GhcException,
79-
OverridingBool (..))
80-
import qualified Development.IDE.GHC.Compat.Util as FastString
28+
import Control.Applicative (Alternative ((<|>)))
29+
import Control.Arrow (second, (>>>))
30+
import Control.Exception (try)
31+
import qualified Control.Exception as E
32+
import Control.Lens (_1, _3, (%~), (<&>), (^.))
33+
import Control.Monad (guard, join, void, when)
34+
import Control.Monad.IO.Class (MonadIO (liftIO))
35+
import Control.Monad.Trans.Except (ExceptT (..))
36+
import Data.Aeson (toJSON)
37+
import Data.Char (isSpace)
38+
import qualified Data.HashMap.Strict as HashMap
39+
import Data.List (dropWhileEnd, find,
40+
intercalate, intersperse)
41+
import Data.Maybe (catMaybes, fromMaybe)
42+
import Data.String (IsString)
43+
import Data.Text (Text)
44+
import qualified Data.Text as T
45+
import Data.Time (getCurrentTime)
46+
import Data.Typeable (Typeable)
47+
import Development.IDE (Action, GetDependencies (..),
48+
GetModIface (..),
49+
GetModSummary (..),
50+
GhcSessionIO (..),
51+
HiFileResult (hirHomeMod, hirModSummary),
52+
HscEnvEq, IdeState,
53+
ModSummaryResult (..),
54+
evalGhcEnv,
55+
hscEnvWithImportPaths,
56+
prettyPrint, runAction,
57+
textToStringBuffer,
58+
toNormalizedFilePath',
59+
uriToFilePath', useNoFile_,
60+
useWithStale_, use_, uses_)
61+
import Development.IDE.Core.Compile (loadModulesHome,
62+
setupFinderCache)
63+
import Development.IDE.Core.Rules (TransitiveDependencies (transitiveModuleDeps))
64+
import Development.IDE.GHC.Compat hiding (typeKind, unitState)
65+
import qualified Development.IDE.GHC.Compat as Compat
66+
import qualified Development.IDE.GHC.Compat as SrcLoc
67+
import Development.IDE.GHC.Compat.Util (GhcException,
68+
OverridingBool (..))
8169
import Development.IDE.Types.Options
82-
import GHC (ClsInst,
83-
ExecOptions (execLineNumber, execSourceFile),
84-
FamInst, GhcMonad,
85-
LoadHowMuch (LoadAllTargets),
86-
NamedThing (getName),
87-
defaultFixity,
88-
execOptions, exprType,
89-
getInfo,
90-
getInteractiveDynFlags,
91-
isImport, isStmt, load,
92-
parseName, pprFamInst,
93-
pprInstance,
94-
setLogAction, setTargets,
95-
typeKind)
96-
import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..))
97-
98-
import Ide.Plugin.Eval.Code (Statement, asStatements,
99-
evalSetup, myExecStmt,
100-
propSetup, resultRange,
101-
testCheck, testRanges)
102-
import Ide.Plugin.Eval.GHC (addImport, addPackages,
103-
hasPackage, showDynFlags)
104-
import Ide.Plugin.Eval.Parse.Comments (commentsToSections)
105-
import Ide.Plugin.Eval.Parse.Option (parseSetFlags)
70+
import GHC (ClsInst,
71+
ExecOptions (execLineNumber, execSourceFile),
72+
FamInst, GhcMonad,
73+
LoadHowMuch (LoadAllTargets),
74+
NamedThing (getName),
75+
defaultFixity, execOptions,
76+
exprType, getInfo,
77+
getInteractiveDynFlags,
78+
isImport, isStmt, load,
79+
parseName, pprFamInst,
80+
pprInstance, setLogAction,
81+
setTargets, typeKind)
82+
import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..))
83+
84+
import Ide.Plugin.Eval.Code (Statement, asStatements,
85+
evalSetup, myExecStmt,
86+
propSetup, resultRange,
87+
testCheck, testRanges)
88+
import Ide.Plugin.Eval.GHC (addImport, addPackages,
89+
hasPackage, showDynFlags)
90+
import Ide.Plugin.Eval.Parse.Comments (commentsToSections)
91+
import Ide.Plugin.Eval.Parse.Option (parseSetFlags)
10692
import Ide.Plugin.Eval.Types
107-
import Ide.Plugin.Eval.Util (asS, gStrictTry,
108-
handleMaybe,
109-
handleMaybeM, isLiterate,
110-
logWith, response,
111-
response', timed)
93+
import Ide.Plugin.Eval.Util (asS, gStrictTry, handleMaybe,
94+
handleMaybeM, isLiterate,
95+
logWith, response, response',
96+
timed)
11297
import Ide.Types
11398
import Language.LSP.Server
114-
import Language.LSP.Types hiding
115-
(SemanticTokenAbsolute (length, line),
116-
SemanticTokenRelative (length))
117-
import Language.LSP.Types.Lens (end, line)
118-
import Language.LSP.VFS (virtualFileText)
119-
import System.FilePath (takeFileName)
120-
import System.IO (hClose)
121-
import UnliftIO.Temporary (withSystemTempFile)
99+
import Language.LSP.Types hiding
100+
(SemanticTokenAbsolute (length, line),
101+
SemanticTokenRelative (length))
102+
import Language.LSP.Types.Lens (end, line)
103+
import Language.LSP.VFS (virtualFileText)
104+
import System.FilePath (takeFileName)
105+
import System.IO (hClose)
106+
import UnliftIO.Temporary (withSystemTempFile)
122107

123108
#if MIN_VERSION_ghc(9,0,0)
124-
import GHC.Driver.Session (unitDatabases, unitState)
125-
import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive))
109+
import GHC.Driver.Session (unitDatabases, unitState)
110+
import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive))
126111
#else
127112
import DynFlags
128113
#endif
129114

130-
#if MIN_VERSION_ghc(9,0,0)
131-
pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan
132-
pattern RealSrcSpanAlready x = x
133-
apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.RealLocated AnnotationComment]
134-
apiAnnComments' = apiAnnRogueComments
135-
#else
136-
apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.Located AnnotationComment]
137-
apiAnnComments' = concat . Map.elems . snd
138-
139-
pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan
140-
pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing
141-
#endif
142-
143115

144116
{- | Code Lens provider
145117
NOTE: Invoked every time the document is modified, not just when the document is saved.
@@ -155,36 +127,16 @@ codeLens st plId CodeLensParams{_textDocument} =
155127
let nfp = toNormalizedFilePath' fp
156128
isLHS = isLiterate fp
157129
dbg "fp" fp
158-
(ParsedModule{..}, posMap) <- liftIO $
159-
runAction "eval.GetParsedModuleWithComments" st $ useWithStale_ GetParsedModuleWithComments nfp
160-
let comments =
161-
foldMap (\case
162-
L (RealSrcSpanAlready real) bdy
163-
| FastString.unpackFS (srcSpanFile real) ==
164-
fromNormalizedFilePath nfp
165-
, let ran0 = realSrcSpanToRange real
166-
, Just curRan <- toCurrentRange posMap ran0
167-
->
168-
169-
-- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments',
170-
-- we can concentrate on these two
171-
case bdy of
172-
AnnLineComment cmt ->
173-
mempty { lineComments = Map.singleton curRan (RawLineComment cmt) }
174-
AnnBlockComment cmt ->
175-
mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt }
176-
_ -> mempty
177-
_ -> mempty
178-
)
179-
$ apiAnnComments' pm_annotations
180-
dbg "excluded comments" $ show $ DL.toList $
181-
foldMap (\(L a b) ->
182-
case b of
183-
AnnLineComment{} -> mempty
184-
AnnBlockComment{} -> mempty
185-
_ -> DL.singleton (a, b)
186-
)
187-
$ apiAnnComments' pm_annotations
130+
(comments, _) <- liftIO $
131+
runAction "eval.GetParsedModuleWithComments" st $ useWithStale_ GetEvalComments nfp
132+
-- dbg "excluded comments" $ show $ DL.toList $
133+
-- foldMap (\(L a b) ->
134+
-- case b of
135+
-- AnnLineComment{} -> mempty
136+
-- AnnBlockComment{} -> mempty
137+
-- _ -> DL.singleton (a, b)
138+
-- )
139+
-- $ apiAnnComments' pm_annotations
188140
dbg "comments" $ show comments
189141

190142
-- Extract tests from source code

‎plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs

Lines changed: 61 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,61 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE LambdaCase #-}
3+
{-# LANGUAGE PatternSynonyms #-}
4+
{-# LANGUAGE RecordWildCards #-}
5+
6+
module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules) where
7+
8+
import qualified Data.Map.Strict as Map
9+
import Development.IDE (GetParsedModuleWithComments (GetParsedModuleWithComments),
10+
Rules,
11+
defineNoDiagnostics,
12+
fromNormalizedFilePath,
13+
realSrcSpanToRange,
14+
useWithStale_)
15+
import Development.IDE.Core.PositionMapping (toCurrentRange)
16+
import Development.IDE.GHC.Compat
17+
import qualified Development.IDE.GHC.Compat as SrcLoc
18+
import qualified Development.IDE.GHC.Compat.Util as FastString
19+
import Ide.Plugin.Eval.Types
20+
21+
22+
rules :: Rules ()
23+
rules = do
24+
evalParsedModuleRule
25+
26+
#if MIN_VERSION_ghc(9,0,0)
27+
pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan
28+
pattern RealSrcSpanAlready x = x
29+
apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.RealLocated AnnotationComment]
30+
apiAnnComments' = apiAnnRogueComments
31+
#else
32+
apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.Located AnnotationComment]
33+
apiAnnComments' = concat . Map.elems . snd
34+
35+
pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan
36+
pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing
37+
#endif
38+
39+
evalParsedModuleRule :: Rules ()
40+
evalParsedModuleRule = defineNoDiagnostics $ \GetEvalComments nfp -> do
41+
(ParsedModule{..}, posMap) <- useWithStale_ GetParsedModuleWithComments nfp
42+
return $ Just $
43+
foldMap (\case
44+
L (RealSrcSpanAlready real) bdy
45+
| FastString.unpackFS (srcSpanFile real) ==
46+
fromNormalizedFilePath nfp
47+
, let ran0 = realSrcSpanToRange real
48+
, Just curRan <- toCurrentRange posMap ran0
49+
->
50+
51+
-- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments',
52+
-- we can concentrate on these two
53+
case bdy of
54+
AnnLineComment cmt ->
55+
mempty { lineComments = Map.singleton curRan (RawLineComment cmt) }
56+
AnnBlockComment cmt ->
57+
mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt }
58+
_ -> mempty
59+
_ -> mempty
60+
)
61+
$ apiAnnComments' pm_annotations

0 commit comments

Comments
 (0)