{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, unqueueForEvaluation, Log) 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_,
use_)
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 qualified Development.IDE.Core.Shake as Shake
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.Logger (Pretty (pretty),
Recorder, WithPriority,
cmapWithPrio)
import GHC.Parser.Annotation
import Ide.Plugin.Eval.Types
import qualified Data.ByteString as BS
newtype Log = LogShake Shake.Log deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
(Int -> Log -> ShowS)
-> (Log -> String) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Log -> ShowS
showsPrec :: Int -> Log -> ShowS
$cshow :: Log -> String
show :: Log -> String
$cshowList :: [Log] -> ShowS
showList :: [Log] -> ShowS
Show
instance Pretty Log where
pretty :: forall ann. Log -> Doc ann
pretty = \case
LogShake Log
shakeLog -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
shakeLog
rules :: Recorder (WithPriority Log) -> Rules ()
rules :: Recorder (WithPriority Log) -> Rules ()
rules Recorder (WithPriority Log)
recorder = do
Recorder (WithPriority Log) -> Rules ()
evalParsedModuleRule Recorder (WithPriority Log)
recorder
Recorder (WithPriority Log) -> Rules ()
redefinedNeedsCompilation Recorder (WithPriority Log)
recorder
Recorder (WithPriority Log) -> Rules ()
isEvaluatingRule Recorder (WithPriority Log)
recorder
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 a. IO a -> Rules a
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 b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (HashSet NormalizedFilePath)
var (\HashSet NormalizedFilePath
fs -> (NormalizedFilePath
-> HashSet NormalizedFilePath -> HashSet NormalizedFilePath
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert NormalizedFilePath
nfp HashSet NormalizedFilePath
fs, ()))
unqueueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()
unqueueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()
unqueueForEvaluation 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 b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (HashSet NormalizedFilePath)
var ((HashSet NormalizedFilePath -> (HashSet NormalizedFilePath, ()))
-> IO ())
-> (HashSet NormalizedFilePath -> (HashSet NormalizedFilePath, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \HashSet NormalizedFilePath
fs -> (NormalizedFilePath
-> HashSet NormalizedFilePath -> HashSet NormalizedFilePath
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.delete NormalizedFilePath
nfp HashSet NormalizedFilePath
fs, ())
#if MIN_VERSION_ghc(9,5,0)
getAnnotations :: Development.IDE.GHC.Compat.Located (HsModule GhcPs) -> [LEpaComment]
getAnnotations :: Located (HsModule GhcPs) -> [LEpaComment]
getAnnotations (L SrcSpan
_ m :: HsModule GhcPs
m@(HsModule { hsmodExt :: forall p. HsModule p -> XCModule p
hsmodExt = XModulePs {hsmodAnn :: XModulePs -> EpAnn AnnsModule
hsmodAnn = EpAnn AnnsModule
anns'}})) =
#else
getAnnotations :: Development.IDE.GHC.Compat.Located HsModule -> [LEpaComment]
getAnnotations (L _ m@(HsModule { hsmodAnn = anns'})) =
#endif
EpAnnComments -> [LEpaComment]
priorComments EpAnnComments
annComments [LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. Semigroup a => a -> a -> a
<> EpAnnComments -> [LEpaComment]
getFollowingComments EpAnnComments
annComments
[LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. Semigroup a => a -> a -> a
<> (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (ImportDecl GhcPs)
-> [LEpaComment])
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (ImportDecl GhcPs)]
-> [LEpaComment]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (ImportDecl GhcPs)
-> [LEpaComment]
forall ann e.
GenLocated (SrcSpanAnn' (EpAnn ann)) e -> [LEpaComment]
getCommentsForDecl (HsModule GhcPs -> [LImportDecl GhcPs]
forall p. HsModule p -> [LImportDecl p]
hsmodImports HsModule GhcPs
m)
[LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. Semigroup a => a -> a -> a
<> (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
-> [LEpaComment])
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)]
-> [LEpaComment]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
-> [LEpaComment]
forall ann e.
GenLocated (SrcSpanAnn' (EpAnn ann)) e -> [LEpaComment]
getCommentsForDecl (HsModule GhcPs -> [LHsDecl GhcPs]
forall p. HsModule p -> [LHsDecl p]
hsmodDecls HsModule GhcPs
m)
where
annComments :: EpAnnComments
annComments = EpAnn AnnsModule -> EpAnnComments
forall an. EpAnn an -> EpAnnComments
epAnnComments EpAnn AnnsModule
anns'
getCommentsForDecl :: GenLocated (SrcSpanAnn' (EpAnn ann)) e
-> [LEpaComment]
(L (SrcSpanAnn (EpAnn Anchor
_ ann
_ EpAnnComments
cs) SrcSpan
_) e
_) = EpAnnComments -> [LEpaComment]
priorComments EpAnnComments
cs [LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. Semigroup a => a -> a -> a
<> EpAnnComments -> [LEpaComment]
getFollowingComments EpAnnComments
cs
getCommentsForDecl (L (SrcSpanAnn (EpAnn ann
EpAnnNotUsed) SrcSpan
_) e
_) = []
apiAnnComments' :: ParsedModule -> [SrcLoc.RealLocated EpaCommentTok]
ParsedModule
pm = do
L Anchor
span (EpaComment EpaCommentTok
c RealSrcSpan
_) <- Located (HsModule GhcPs) -> [LEpaComment]
getAnnotations (Located (HsModule GhcPs) -> [LEpaComment])
-> Located (HsModule GhcPs) -> [LEpaComment]
forall a b. (a -> b) -> a -> b
$ ParsedModule -> Located (HsModule GhcPs)
pm_parsed_source ParsedModule
pm
RealLocated EpaCommentTok -> [RealLocated EpaCommentTok]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RealSrcSpan -> EpaCommentTok -> RealLocated EpaCommentTok
forall l e. l -> e -> GenLocated l e
L (Anchor -> RealSrcSpan
anchor Anchor
span) EpaCommentTok
c)
pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan
pattern $mRealSrcSpanAlready :: forall {r}. RealSrcSpan -> (RealSrcSpan -> r) -> ((# #) -> r) -> r
$bRealSrcSpanAlready :: RealSrcSpan -> RealSrcSpan
RealSrcSpanAlready x = x
evalParsedModuleRule :: Recorder (WithPriority Log) -> Rules ()
evalParsedModuleRule :: Recorder (WithPriority Log) -> Rules ()
evalParsedModuleRule Recorder (WithPriority Log)
recorder = Recorder (WithPriority Log)
-> RuleBody GetEvalComments Comments -> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) (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
pm, 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 = (RealLocated EpaCommentTok -> Comments)
-> [RealLocated EpaCommentTok] -> Comments
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\case
L (RealSrcSpanAlready RealSrcSpan
real) EpaCommentTok
bdy
| FastString -> String
FastString.unpackFS (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
real) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==
NormalizedFilePath -> String
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 EpaCommentTok
bdy of
EpaLineComment String
cmt ->
Comments
forall a. Monoid a => a
mempty { lineComments = Map.singleton curRan (RawLineComment cmt) }
EpaBlockComment String
cmt ->
Comments
forall a. Monoid a => a
mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt }
EpaCommentTok
_ -> Comments
forall a. Monoid a => a
mempty
RealLocated EpaCommentTok
_ -> Comments
forall a. Monoid a => a
mempty
)
([RealLocated EpaCommentTok] -> Comments)
-> [RealLocated EpaCommentTok] -> Comments
forall a b. (a -> b) -> a -> b
$ ParsedModule -> [RealLocated EpaCommentTok]
apiAnnComments' ParsedModule
pm
fingerPrint :: ByteString
fingerPrint = String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ if Comments -> Bool
nullComments Comments
comments then String
"" else String
"1"
(Maybe ByteString, Maybe Comments)
-> Action (Maybe ByteString, Maybe Comments)
forall a. a -> Action a
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)
isEvaluatingRule :: Recorder (WithPriority Log) -> Rules ()
isEvaluatingRule :: Recorder (WithPriority Log) -> Rules ()
isEvaluatingRule Recorder (WithPriority Log)
recorder = Recorder (WithPriority Log)
-> RuleBody IsEvaluating Bool -> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) (RuleBody IsEvaluating Bool -> Rules ())
-> RuleBody IsEvaluating Bool -> Rules ()
forall a b. (a -> b) -> a -> b
$ (IsEvaluating
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool))
-> RuleBody IsEvaluating Bool
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics ((IsEvaluating
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool))
-> RuleBody IsEvaluating Bool)
-> (IsEvaluating
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool))
-> RuleBody IsEvaluating Bool
forall a b. (a -> b) -> a -> b
$ \IsEvaluating
IsEvaluating NormalizedFilePath
f -> do
Action ()
alwaysRerun
EvaluatingVar IORef (HashSet NormalizedFilePath)
var <- Action EvaluatingVar
forall a. (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction
Bool
b <- IO Bool -> Action Bool
forall a. IO a -> Action a
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 `Set.member`) (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
(Maybe ByteString, Maybe Bool)
-> Action (Maybe ByteString, Maybe Bool)
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (if Bool
b then Word8 -> ByteString
BS.singleton Word8
1 else ByteString
BS.empty), Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
b)
redefinedNeedsCompilation :: Recorder (WithPriority Log) -> Rules ()
redefinedNeedsCompilation :: Recorder (WithPriority Log) -> Rules ()
redefinedNeedsCompilation Recorder (WithPriority Log)
recorder = Recorder (WithPriority Log)
-> RuleBody NeedsCompilation (Maybe LinkableType) -> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) (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
Bool
isEvaluating <- IsEvaluating -> NormalizedFilePath -> Action Bool
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ IsEvaluating
IsEvaluating NormalizedFilePath
f
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
(Maybe ByteString, Maybe (Maybe LinkableType))
-> Action (Maybe ByteString, Maybe (Maybe LinkableType))
forall a. a -> Action a
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))