Skip to content

Commit

Permalink
extract GetEvalComments rule
Browse files Browse the repository at this point in the history
  • Loading branch information
@pepeiborra
pepeiborra committed Oct 24, 2021
1 parent 8367bb4 commit 961fc0b
Show file tree
Hide file tree
Showing 5 changed files with 175 additions and 145 deletions.
2 changes: 2 additions & 0 deletions plugins/hls-eval-plugin/hls-eval-plugin.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -48,6 +48,7 @@ library
Ide.Plugin.Eval.GHC
Ide.Plugin.Eval.Parse.Comments
Ide.Plugin.Eval.Parse.Option
Ide.Plugin.Eval.Rules
Ide.Plugin.Eval.Util

build-depends:
Expand All @@ -65,6 +66,7 @@ library
, ghc-paths
, ghcide >=1.2 && <1.5
, hashable
, hls-graph
, hls-plugin-api ^>=1.2
, lens
, lsp
Expand Down
2 changes: 2 additions & 0 deletions plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@ module Ide.Plugin.Eval (

import Development.IDE (IdeState)
import qualified Ide.Plugin.Eval.CodeLens as CL
import Ide.Plugin.Eval.Rules (rules)
import Ide.Types (PluginDescriptor (..), PluginId,
defaultPluginDescriptor,
mkPluginHandler)
Expand All @@ -22,4 +23,5 @@ descriptor plId =
(defaultPluginDescriptor plId)
{ pluginHandlers = mkPluginHandler STextDocumentCodeLens CL.codeLens
, pluginCommands = [CL.evalCommand]
, pluginRules = rules
}
222 changes: 87 additions & 135 deletions plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,121 +25,93 @@ module Ide.Plugin.Eval.CodeLens (
evalCommand,
) where

import Control.Applicative (Alternative ((<|>)))
import Control.Arrow (second, (>>>))
import Control.Exception (try)
import qualified Control.Exception as E
import Control.Lens (_1, _3, (%~), (<&>),
(^.))
import Control.Monad (guard, join, void, when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Except (ExceptT (..))
import Data.Aeson (toJSON)
import Data.Char (isSpace)
import qualified Data.DList as DL
import qualified Data.HashMap.Strict as HashMap
import Data.List (dropWhileEnd, find,
intercalate, intersperse)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromMaybe)
import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (getCurrentTime)
import Data.Typeable (Typeable)
import Development.IDE (Action,
GetDependencies (..),
GetModIface (..),
GetModSummary (..),
GetParsedModuleWithComments (..),
GhcSessionIO (..),
HiFileResult (hirHomeMod, hirModSummary),
HscEnvEq, IdeState,
ModSummaryResult (..),
evalGhcEnv,
hscEnvWithImportPaths,
prettyPrint,
realSrcSpanToRange,
runAction,
textToStringBuffer,
toNormalizedFilePath',
uriToFilePath',
useNoFile_,
useWithStale_, use_,
uses_)
import Development.IDE.Core.Compile (loadModulesHome,
setupFinderCache)
import Development.IDE.Core.PositionMapping (toCurrentRange)
import Development.IDE.Core.Rules (TransitiveDependencies (transitiveModuleDeps))
import Development.IDE.GHC.Compat hiding (typeKind,
unitState)
import qualified Development.IDE.GHC.Compat as Compat
import qualified Development.IDE.GHC.Compat as SrcLoc
import Development.IDE.GHC.Compat.Util (GhcException,
OverridingBool (..))
import qualified Development.IDE.GHC.Compat.Util as FastString
import Control.Applicative (Alternative ((<|>)))
import Control.Arrow (second, (>>>))
import Control.Exception (try)
import qualified Control.Exception as E
import Control.Lens (_1, _3, (%~), (<&>), (^.))
import Control.Monad (guard, join, void, when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Except (ExceptT (..))
import Data.Aeson (toJSON)
import Data.Char (isSpace)
import qualified Data.HashMap.Strict as HashMap
import Data.List (dropWhileEnd, find,
intercalate, intersperse)
import Data.Maybe (catMaybes, fromMaybe)
import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (getCurrentTime)
import Data.Typeable (Typeable)
import Development.IDE (Action, GetDependencies (..),
GetModIface (..),
GetModSummary (..),
GhcSessionIO (..),
HiFileResult (hirHomeMod, hirModSummary),
HscEnvEq, IdeState,
ModSummaryResult (..),
evalGhcEnv,
hscEnvWithImportPaths,
prettyPrint, runAction,
textToStringBuffer,
toNormalizedFilePath',
uriToFilePath', useNoFile_,
useWithStale_, use_, uses_)
import Development.IDE.Core.Compile (loadModulesHome,
setupFinderCache)
import Development.IDE.Core.Rules (TransitiveDependencies (transitiveModuleDeps))
import Development.IDE.GHC.Compat hiding (typeKind, unitState)
import qualified Development.IDE.GHC.Compat as Compat
import qualified Development.IDE.GHC.Compat as SrcLoc
import Development.IDE.GHC.Compat.Util (GhcException,
OverridingBool (..))
import Development.IDE.Types.Options
import GHC (ClsInst,
ExecOptions (execLineNumber, execSourceFile),
FamInst, GhcMonad,
LoadHowMuch (LoadAllTargets),
NamedThing (getName),
defaultFixity,
execOptions, exprType,
getInfo,
getInteractiveDynFlags,
isImport, isStmt, load,
parseName, pprFamInst,
pprInstance,
setLogAction, setTargets,
typeKind)
import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..))

import Ide.Plugin.Eval.Code (Statement, asStatements,
evalSetup, myExecStmt,
propSetup, resultRange,
testCheck, testRanges)
import Ide.Plugin.Eval.GHC (addImport, addPackages,
hasPackage, showDynFlags)
import Ide.Plugin.Eval.Parse.Comments (commentsToSections)
import Ide.Plugin.Eval.Parse.Option (parseSetFlags)
import GHC (ClsInst,
ExecOptions (execLineNumber, execSourceFile),
FamInst, GhcMonad,
LoadHowMuch (LoadAllTargets),
NamedThing (getName),
defaultFixity, execOptions,
exprType, getInfo,
getInteractiveDynFlags,
isImport, isStmt, load,
parseName, pprFamInst,
pprInstance, setLogAction,
setTargets, typeKind)
import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..))

import Ide.Plugin.Eval.Code (Statement, asStatements,
evalSetup, myExecStmt,
propSetup, resultRange,
testCheck, testRanges)
import Ide.Plugin.Eval.GHC (addImport, addPackages,
hasPackage, showDynFlags)
import Ide.Plugin.Eval.Parse.Comments (commentsToSections)
import Ide.Plugin.Eval.Parse.Option (parseSetFlags)
import Ide.Plugin.Eval.Types
import Ide.Plugin.Eval.Util (asS, gStrictTry,
handleMaybe,
handleMaybeM, isLiterate,
logWith, response,
response', timed)
import Ide.Plugin.Eval.Util (asS, gStrictTry, handleMaybe,
handleMaybeM, isLiterate,
logWith, response, response',
timed)
import Ide.Types
import Language.LSP.Server
import Language.LSP.Types hiding
(SemanticTokenAbsolute (length, line),
SemanticTokenRelative (length))
import Language.LSP.Types.Lens (end, line)
import Language.LSP.VFS (virtualFileText)
import System.FilePath (takeFileName)
import System.IO (hClose)
import UnliftIO.Temporary (withSystemTempFile)
import Language.LSP.Types hiding
(SemanticTokenAbsolute (length, line),
SemanticTokenRelative (length))
import Language.LSP.Types.Lens (end, line)
import Language.LSP.VFS (virtualFileText)
import System.FilePath (takeFileName)
import System.IO (hClose)
import UnliftIO.Temporary (withSystemTempFile)

#if MIN_VERSION_ghc(9,0,0)
import GHC.Driver.Session (unitDatabases, unitState)
import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive))
import GHC.Driver.Session (unitDatabases, unitState)
import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive))
#else
import DynFlags
#endif

#if MIN_VERSION_ghc(9,0,0)
pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan
pattern RealSrcSpanAlready x = x
apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.RealLocated AnnotationComment]
apiAnnComments' = apiAnnRogueComments
#else
apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.Located AnnotationComment]
apiAnnComments' = concat . Map.elems . snd

pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan
pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing
#endif


{- | Code Lens provider
NOTE: Invoked every time the document is modified, not just when the document is saved.
Expand All @@ -155,36 +127,16 @@ codeLens st plId CodeLensParams{_textDocument} =
let nfp = toNormalizedFilePath' fp
isLHS = isLiterate fp
dbg "fp" fp
(ParsedModule{..}, posMap) <- liftIO $
runAction "eval.GetParsedModuleWithComments" st $ useWithStale_ GetParsedModuleWithComments nfp
let comments =
foldMap (\case
L (RealSrcSpanAlready real) bdy
| FastString.unpackFS (srcSpanFile real) ==
fromNormalizedFilePath nfp
, let ran0 = realSrcSpanToRange real
, Just curRan <- toCurrentRange posMap ran0
->

-- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments',
-- we can concentrate on these two
case bdy of
AnnLineComment cmt ->
mempty { lineComments = Map.singleton curRan (RawLineComment cmt) }
AnnBlockComment cmt ->
mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt }
_ -> mempty
_ -> mempty
)
$ apiAnnComments' pm_annotations
dbg "excluded comments" $ show $ DL.toList $
foldMap (\(L a b) ->
case b of
AnnLineComment{} -> mempty
AnnBlockComment{} -> mempty
_ -> DL.singleton (a, b)
)
$ apiAnnComments' pm_annotations
(comments, _) <- liftIO $
runAction "eval.GetParsedModuleWithComments" st $ useWithStale_ GetEvalComments nfp
-- dbg "excluded comments" $ show $ DL.toList $
-- foldMap (\(L a b) ->
-- case b of
-- AnnLineComment{} -> mempty
-- AnnBlockComment{} -> mempty
-- _ -> DL.singleton (a, b)
-- )
-- $ apiAnnComments' pm_annotations
dbg "comments" $ show comments

-- Extract tests from source code
Expand Down
61 changes: 61 additions & 0 deletions plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,61 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}

module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules) where

import qualified Data.Map.Strict as Map
import Development.IDE (GetParsedModuleWithComments (GetParsedModuleWithComments),
Rules,
defineNoDiagnostics,
fromNormalizedFilePath,
realSrcSpanToRange,
useWithStale_)
import Development.IDE.Core.PositionMapping (toCurrentRange)
import Development.IDE.GHC.Compat
import qualified Development.IDE.GHC.Compat as SrcLoc
import qualified Development.IDE.GHC.Compat.Util as FastString
import Ide.Plugin.Eval.Types


rules :: Rules ()
rules = do
evalParsedModuleRule

#if MIN_VERSION_ghc(9,0,0)
pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan
pattern RealSrcSpanAlready x = x
apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.RealLocated AnnotationComment]
apiAnnComments' = apiAnnRogueComments
#else
apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.Located AnnotationComment]
apiAnnComments' = concat . Map.elems . snd

pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan
pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing
#endif

evalParsedModuleRule :: Rules ()
evalParsedModuleRule = defineNoDiagnostics $ \GetEvalComments nfp -> do
(ParsedModule{..}, posMap) <- useWithStale_ GetParsedModuleWithComments nfp
return $ Just $
foldMap (\case
L (RealSrcSpanAlready real) bdy
| FastString.unpackFS (srcSpanFile real) ==
fromNormalizedFilePath nfp
, let ran0 = realSrcSpanToRange real
, Just curRan <- toCurrentRange posMap ran0
->

-- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments',
-- we can concentrate on these two
case bdy of
AnnLineComment cmt ->
mempty { lineComments = Map.singleton curRan (RawLineComment cmt) }
AnnBlockComment cmt ->
mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt }
_ -> mempty
_ -> mempty
)
$ apiAnnComments' pm_annotations
Loading

0 comments on commit 961fc0b

Please sign in to comment.