{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation) where
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.HashSet (HashSet)
import qualified Data.HashSet as Set
import Data.IORef
import qualified Data.Map.Strict as Map
import Data.String (fromString)
import Development.IDE (GetModSummaryWithoutTimestamps (GetModSummaryWithoutTimestamps),
GetParsedModuleWithComments (GetParsedModuleWithComments),
IdeState,
NeedsCompilation (NeedsCompilation),
NormalizedFilePath,
RuleBody (RuleNoDiagnostics),
Rules, defineEarlyCutoff,
encodeLinkableType,
fromNormalizedFilePath,
msrModSummary,
realSrcSpanToRange,
useWithStale_)
import Development.IDE.Core.PositionMapping (toCurrentRange)
import Development.IDE.Core.Rules (computeLinkableTypeForDynFlags,
needsCompilationRule)
import Development.IDE.Core.Shake (IsIdeGlobal,
RuleBody (RuleWithCustomNewnessCheck),
addIdeGlobal,
getIdeGlobalAction,
getIdeGlobalState)
import Development.IDE.GHC.Compat
import qualified Development.IDE.GHC.Compat as SrcLoc
import qualified Development.IDE.GHC.Compat.Util as FastString
import Development.IDE.Graph (alwaysRerun)
import Ide.Plugin.Eval.Types
rules :: Rules ()
rules :: Rules ()
rules = do
Rules ()
evalParsedModuleRule
Rules ()
redefinedNeedsCompilation
EvaluatingVar -> Rules ()
forall a. IsIdeGlobal a => a -> Rules ()
addIdeGlobal (EvaluatingVar -> Rules ())
-> (IORef (HashSet NormalizedFilePath) -> EvaluatingVar)
-> IORef (HashSet NormalizedFilePath)
-> Rules ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (HashSet NormalizedFilePath) -> EvaluatingVar
EvaluatingVar (IORef (HashSet NormalizedFilePath) -> Rules ())
-> Rules (IORef (HashSet NormalizedFilePath)) -> Rules ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (IORef (HashSet NormalizedFilePath))
-> Rules (IORef (HashSet NormalizedFilePath))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(HashSet NormalizedFilePath
-> IO (IORef (HashSet NormalizedFilePath))
forall a. a -> IO (IORef a)
newIORef HashSet NormalizedFilePath
forall a. Monoid a => a
mempty)
newtype EvaluatingVar = EvaluatingVar (IORef (HashSet NormalizedFilePath))
instance IsIdeGlobal EvaluatingVar
queueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()
queueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()
queueForEvaluation IdeState
ide NormalizedFilePath
nfp = do
EvaluatingVar IORef (HashSet NormalizedFilePath)
var <- IdeState -> IO EvaluatingVar
forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
ide
IORef (HashSet NormalizedFilePath)
-> (HashSet NormalizedFilePath -> HashSet NormalizedFilePath)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (HashSet NormalizedFilePath)
var (NormalizedFilePath
-> HashSet NormalizedFilePath -> HashSet NormalizedFilePath
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert NormalizedFilePath
nfp)
#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]
= [[Located AnnotationComment]] -> [Located AnnotationComment]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Located AnnotationComment]] -> [Located AnnotationComment])
-> (ApiAnns -> [[Located AnnotationComment]])
-> ApiAnns
-> [Located AnnotationComment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map SrcSpan [Located AnnotationComment]
-> [[Located AnnotationComment]]
forall k a. Map k a -> [a]
Map.elems (Map SrcSpan [Located AnnotationComment]
-> [[Located AnnotationComment]])
-> (ApiAnns -> Map SrcSpan [Located AnnotationComment])
-> ApiAnns
-> [[Located AnnotationComment]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApiAnns -> Map SrcSpan [Located AnnotationComment]
forall a b. (a, b) -> b
snd
pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan
pattern $bRealSrcSpanAlready :: RealSrcSpan -> SrcSpan
$mRealSrcSpanAlready :: forall r. SrcSpan -> (RealSrcSpan -> r) -> (Void# -> r) -> r
RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing
#endif
evalParsedModuleRule :: Rules ()
evalParsedModuleRule :: Rules ()
evalParsedModuleRule = RuleBody GetEvalComments Comments -> Rules ()
forall k v. IdeRule k v => RuleBody k v -> Rules ()
defineEarlyCutoff (RuleBody GetEvalComments Comments -> Rules ())
-> RuleBody GetEvalComments Comments -> Rules ()
forall a b. (a -> b) -> a -> b
$ (GetEvalComments
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Comments))
-> RuleBody GetEvalComments Comments
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics ((GetEvalComments
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Comments))
-> RuleBody GetEvalComments Comments)
-> (GetEvalComments
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Comments))
-> RuleBody GetEvalComments Comments
forall a b. (a -> b) -> a -> b
$ \GetEvalComments
GetEvalComments NormalizedFilePath
nfp -> do
(ParsedModule{[FilePath]
ApiAnns
ModSummary
ParsedSource
pm_mod_summary :: ParsedModule -> ModSummary
pm_parsed_source :: ParsedModule -> ParsedSource
pm_extra_src_files :: ParsedModule -> [FilePath]
pm_annotations :: ParsedModule -> ApiAnns
pm_annotations :: ApiAnns
pm_extra_src_files :: [FilePath]
pm_parsed_source :: ParsedSource
pm_mod_summary :: ModSummary
..}, PositionMapping
posMap) <- GetParsedModuleWithComments
-> NormalizedFilePath -> Action (ParsedModule, PositionMapping)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ GetParsedModuleWithComments
GetParsedModuleWithComments NormalizedFilePath
nfp
let comments :: Comments
comments = (Located AnnotationComment -> Comments)
-> [Located AnnotationComment] -> Comments
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\case
L (RealSrcSpanAlready RealSrcSpan
real) AnnotationComment
bdy
| FastString -> FilePath
FastString.unpackFS (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
real) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==
NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
nfp
, let ran0 :: Range
ran0 = RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
real
, Just Range
curRan <- PositionMapping -> Range -> Maybe Range
toCurrentRange PositionMapping
posMap Range
ran0
->
case AnnotationComment
bdy of
AnnLineComment FilePath
cmt ->
Comments
forall a. Monoid a => a
mempty { lineComments :: Map Range RawLineComment
lineComments = Range -> RawLineComment -> Map Range RawLineComment
forall k a. k -> a -> Map k a
Map.singleton Range
curRan (FilePath -> RawLineComment
RawLineComment FilePath
cmt) }
AnnBlockComment FilePath
cmt ->
Comments
forall a. Monoid a => a
mempty { blockComments :: Map Range RawBlockComment
blockComments = Range -> RawBlockComment -> Map Range RawBlockComment
forall k a. k -> a -> Map k a
Map.singleton Range
curRan (RawBlockComment -> Map Range RawBlockComment)
-> RawBlockComment -> Map Range RawBlockComment
forall a b. (a -> b) -> a -> b
$ FilePath -> RawBlockComment
RawBlockComment FilePath
cmt }
AnnotationComment
_ -> Comments
forall a. Monoid a => a
mempty
Located AnnotationComment
_ -> Comments
forall a. Monoid a => a
mempty
)
([Located AnnotationComment] -> Comments)
-> [Located AnnotationComment] -> Comments
forall a b. (a -> b) -> a -> b
$ ApiAnns -> [Located AnnotationComment]
apiAnnComments' ApiAnns
pm_annotations
fingerPrint :: ByteString
fingerPrint = FilePath -> ByteString
forall a. IsString a => FilePath -> a
fromString (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ if Comments -> Bool
nullComments Comments
comments then FilePath
"" else FilePath
"1"
(Maybe ByteString, Maybe Comments)
-> Action (Maybe ByteString, Maybe Comments)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
fingerPrint, Comments -> Maybe Comments
forall a. a -> Maybe a
Just Comments
comments)
redefinedNeedsCompilation :: Rules ()
redefinedNeedsCompilation :: Rules ()
redefinedNeedsCompilation = RuleBody NeedsCompilation (Maybe LinkableType) -> Rules ()
forall k v. IdeRule k v => RuleBody k v -> Rules ()
defineEarlyCutoff (RuleBody NeedsCompilation (Maybe LinkableType) -> Rules ())
-> RuleBody NeedsCompilation (Maybe LinkableType) -> Rules ()
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString -> Bool)
-> (NeedsCompilation
-> NormalizedFilePath
-> Action (Maybe ByteString, Maybe (Maybe LinkableType)))
-> RuleBody NeedsCompilation (Maybe LinkableType)
forall k v.
(ByteString -> ByteString -> Bool)
-> (k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleWithCustomNewnessCheck ByteString -> ByteString -> Bool
forall a. Ord a => a -> a -> Bool
(<=) ((NeedsCompilation
-> NormalizedFilePath
-> Action (Maybe ByteString, Maybe (Maybe LinkableType)))
-> RuleBody NeedsCompilation (Maybe LinkableType))
-> (NeedsCompilation
-> NormalizedFilePath
-> Action (Maybe ByteString, Maybe (Maybe LinkableType)))
-> RuleBody NeedsCompilation (Maybe LinkableType)
forall a b. (a -> b) -> a -> b
$ \NeedsCompilation
NeedsCompilation NormalizedFilePath
f -> do
Action ()
alwaysRerun
EvaluatingVar IORef (HashSet NormalizedFilePath)
var <- Action EvaluatingVar
forall a. IsIdeGlobal a => Action a
getIdeGlobalAction
Bool
isEvaluating <- IO Bool -> Action Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Action Bool) -> IO Bool -> Action Bool
forall a b. (a -> b) -> a -> b
$ (NormalizedFilePath
f NormalizedFilePath -> HashSet NormalizedFilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) (HashSet NormalizedFilePath -> Bool)
-> IO (HashSet NormalizedFilePath) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (HashSet NormalizedFilePath)
-> IO (HashSet NormalizedFilePath)
forall a. IORef a -> IO a
readIORef IORef (HashSet NormalizedFilePath)
var
if Bool -> Bool
not Bool
isEvaluating then NormalizedFilePath
-> Action (Maybe ByteString, Maybe (Maybe LinkableType))
needsCompilationRule NormalizedFilePath
f else do
ModSummary
ms <- ModSummaryResult -> ModSummary
msrModSummary (ModSummaryResult -> ModSummary)
-> ((ModSummaryResult, PositionMapping) -> ModSummaryResult)
-> (ModSummaryResult, PositionMapping)
-> ModSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModSummaryResult, PositionMapping) -> ModSummaryResult
forall a b. (a, b) -> a
fst ((ModSummaryResult, PositionMapping) -> ModSummary)
-> Action (ModSummaryResult, PositionMapping) -> Action ModSummary
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetModSummaryWithoutTimestamps
-> NormalizedFilePath -> Action (ModSummaryResult, PositionMapping)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps NormalizedFilePath
f
let df' :: DynFlags
df' = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
linkableType :: LinkableType
linkableType = DynFlags -> LinkableType
computeLinkableTypeForDynFlags DynFlags
df'
fp :: ByteString
fp = Maybe LinkableType -> ByteString
encodeLinkableType (Maybe LinkableType -> ByteString)
-> Maybe LinkableType -> ByteString
forall a b. (a -> b) -> a -> b
$ LinkableType -> Maybe LinkableType
forall a. a -> Maybe a
Just LinkableType
linkableType
IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ IORef (HashSet NormalizedFilePath)
-> (HashSet NormalizedFilePath -> HashSet NormalizedFilePath)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (HashSet NormalizedFilePath)
var (NormalizedFilePath
-> HashSet NormalizedFilePath -> HashSet NormalizedFilePath
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.delete NormalizedFilePath
f)
(Maybe ByteString, Maybe (Maybe LinkableType))
-> Action (Maybe ByteString, Maybe (Maybe LinkableType))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
fp, Maybe LinkableType -> Maybe (Maybe LinkableType)
forall a. a -> Maybe a
Just (LinkableType -> Maybe LinkableType
forall a. a -> Maybe a
Just LinkableType
linkableType))