{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeFamilies          #-}

module Ide.Plugin.Cabal (descriptor, Log(..)) where

import           Control.Concurrent.STM
import           Control.Concurrent.Strict
import           Control.DeepSeq
import           Control.Monad.Extra
import           Control.Monad.IO.Class
import qualified Data.ByteString                 as BS
import           Data.Hashable
import           Data.HashMap.Strict             (HashMap)
import qualified Data.HashMap.Strict             as HashMap
import qualified Data.List.NonEmpty              as NE
import qualified Data.Text.Encoding              as Encoding
import           Data.Typeable
import           Development.IDE                 as D
import           Development.IDE.Core.Shake      (restartShakeSession)
import qualified Development.IDE.Core.Shake      as Shake
import           Development.IDE.Graph           (alwaysRerun)
import           GHC.Generics
import qualified Ide.Plugin.Cabal.Diagnostics    as Diagnostics
import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest
import qualified Ide.Plugin.Cabal.Parse          as Parse
import           Ide.Plugin.Config               (Config)
import           Ide.Types
import           Language.LSP.Server             (LspM)
import           Language.LSP.Types
import qualified Language.LSP.Types              as LSP
import qualified Language.LSP.VFS                as VFS

data Log
  = LogModificationTime NormalizedFilePath FileVersion
  | LogShake Shake.Log
  | LogDocOpened Uri
  | LogDocModified Uri
  | LogDocSaved Uri
  | LogDocClosed Uri
  | LogFOI (HashMap NormalizedFilePath FileOfInterestStatus)
  deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> [Char]
$cshow :: Log -> [Char]
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogShake Log
log' -> forall a ann. Pretty a => a -> Doc ann
pretty Log
log'
    LogModificationTime NormalizedFilePath
nfp FileVersion
modTime  ->
      Doc ann
"Modified:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
nfp) forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> [Char]
show FileVersion
modTime)
    LogDocOpened Uri
uri ->
      Doc ann
"Opened text document:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (Uri -> Text
getUri Uri
uri)
    LogDocModified Uri
uri ->
      Doc ann
"Modified text document:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (Uri -> Text
getUri Uri
uri)
    LogDocSaved Uri
uri ->
      Doc ann
"Saved text document:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (Uri -> Text
getUri Uri
uri)
    LogDocClosed Uri
uri ->
      Doc ann
"Closed text document:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (Uri -> Text
getUri Uri
uri)
    LogFOI HashMap NormalizedFilePath FileOfInterestStatus
files ->
      Doc ann
"Set files of interest to:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow HashMap NormalizedFilePath FileOfInterestStatus
files


descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
plId = (forall ideState. PluginId -> PluginDescriptor ideState
defaultCabalPluginDescriptor PluginId
plId)
  { pluginRules :: Rules ()
pluginRules = Recorder (WithPriority Log) -> Rules ()
cabalRules Recorder (WithPriority Log)
recorder
  , pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentCodeAction
STextDocumentCodeAction IdeState
-> PluginId
-> CodeActionParams
-> LspM
     Config
     (Either ResponseError (ResponseResult 'TextDocumentCodeAction))
licenseSuggestCodeAction
  , pluginNotificationHandlers :: PluginNotificationHandlers IdeState
pluginNotificationHandlers = forall a. Monoid a => [a] -> a
mconcat
  [ forall (m :: Method 'FromClient 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'TextDocumentDidOpen
LSP.STextDocumentDidOpen forall a b. (a -> b) -> a -> b
$
      \IdeState
ide VFS
vfs PluginId
_ (DidOpenTextDocumentParams TextDocumentItem{Uri
$sel:_uri:TextDocumentItem :: TextDocumentItem -> Uri
_uri :: Uri
_uri,Int32
$sel:_version:TextDocumentItem :: TextDocumentItem -> Int32
_version :: Int32
_version}) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
        Priority -> Log -> IO ()
log' Priority
Debug forall a b. (a -> b) -> a -> b
$ Uri -> Log
LogDocOpened Uri
_uri
        Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file Modified{firstOpen :: Bool
firstOpen=Bool
True}
        ShakeExtras -> VFS -> NormalizedFilePath -> [Char] -> IO ()
restartCabalShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
ide) VFS
vfs NormalizedFilePath
file [Char]
"(opened)"

  , forall (m :: Method 'FromClient 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'TextDocumentDidChange
LSP.STextDocumentDidChange forall a b. (a -> b) -> a -> b
$
      \IdeState
ide VFS
vfs PluginId
_ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{Uri
$sel:_uri:VersionedTextDocumentIdentifier :: VersionedTextDocumentIdentifier -> Uri
_uri :: Uri
_uri} List TextDocumentContentChangeEvent
_) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
        Priority -> Log -> IO ()
log' Priority
Debug forall a b. (a -> b) -> a -> b
$ Uri -> Log
LogDocModified Uri
_uri
        Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file Modified{firstOpen :: Bool
firstOpen=Bool
False}
        ShakeExtras -> VFS -> NormalizedFilePath -> [Char] -> IO ()
restartCabalShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
ide) VFS
vfs NormalizedFilePath
file [Char]
"(changed)"

  , forall (m :: Method 'FromClient 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'TextDocumentDidSave
LSP.STextDocumentDidSave forall a b. (a -> b) -> a -> b
$
      \IdeState
ide VFS
vfs PluginId
_ (DidSaveTextDocumentParams TextDocumentIdentifier{Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri} Maybe Text
_) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
        Priority -> Log -> IO ()
log' Priority
Debug forall a b. (a -> b) -> a -> b
$ Uri -> Log
LogDocSaved Uri
_uri
        Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file FileOfInterestStatus
OnDisk
        ShakeExtras -> VFS -> NormalizedFilePath -> [Char] -> IO ()
restartCabalShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
ide) VFS
vfs NormalizedFilePath
file [Char]
"(saved)"

  , forall (m :: Method 'FromClient 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'TextDocumentDidClose
LSP.STextDocumentDidClose forall a b. (a -> b) -> a -> b
$
      \IdeState
ide VFS
vfs PluginId
_ (DidCloseTextDocumentParams TextDocumentIdentifier{Uri
_uri :: Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri}) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
        Priority -> Log -> IO ()
log' Priority
Debug forall a b. (a -> b) -> a -> b
$ Uri -> Log
LogDocClosed Uri
_uri
        Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> IO ()
deleteFileOfInterest Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file
        ShakeExtras -> VFS -> NormalizedFilePath -> [Char] -> IO ()
restartCabalShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
ide) VFS
vfs NormalizedFilePath
file [Char]
"(closed)"
  ]
  }
  where
    log' :: Priority -> Log -> IO ()
log' = forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder

    whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
    whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
uri NormalizedFilePath -> IO ()
act = forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Uri -> Maybe [Char]
LSP.uriToFilePath Uri
uri) forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> IO ()
act forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> NormalizedFilePath
toNormalizedFilePath'

-- | Helper function to restart the shake session, specifically for modifying .cabal files.
-- No special logic, just group up a bunch of functions you need for the base
-- Notification Handlers.
--
-- To make sure diagnostics are up to date, we need to tell shake that the file was touched and
-- needs to be re-parsed. That's what we do when we record the dirty key that our parsing
-- rule depends on.
-- Then we restart the shake session, so that changes to our virtual files are actually picked up.
restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO ()
restartCabalShakeSession :: ShakeExtras -> VFS -> NormalizedFilePath -> [Char] -> IO ()
restartCabalShakeSession ShakeExtras
shakeExtras VFS
vfs NormalizedFilePath
file [Char]
actionMsg = do
  forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall k.
ShakeValue k =>
ShakeExtras -> k -> [NormalizedFilePath] -> STM (IO ())
Shake.recordDirtyKeys ShakeExtras
shakeExtras GetModificationTime
GetModificationTime [NormalizedFilePath
file]
  ShakeExtras -> VFSModified -> [Char] -> [DelayedAction ()] -> IO ()
restartShakeSession ShakeExtras
shakeExtras (VFS -> VFSModified
VFSModified VFS
vfs) (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
file forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ [Char]
actionMsg) []

-- ----------------------------------------------------------------
-- Plugin Rules
-- ----------------------------------------------------------------

data ParseCabal = ParseCabal
    deriving (ParseCabal -> ParseCabal -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseCabal -> ParseCabal -> Bool
$c/= :: ParseCabal -> ParseCabal -> Bool
== :: ParseCabal -> ParseCabal -> Bool
$c== :: ParseCabal -> ParseCabal -> Bool
Eq, Int -> ParseCabal -> ShowS
[ParseCabal] -> ShowS
ParseCabal -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ParseCabal] -> ShowS
$cshowList :: [ParseCabal] -> ShowS
show :: ParseCabal -> [Char]
$cshow :: ParseCabal -> [Char]
showsPrec :: Int -> ParseCabal -> ShowS
$cshowsPrec :: Int -> ParseCabal -> ShowS
Show, Typeable, forall x. Rep ParseCabal x -> ParseCabal
forall x. ParseCabal -> Rep ParseCabal x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ParseCabal x -> ParseCabal
$cfrom :: forall x. ParseCabal -> Rep ParseCabal x
Generic)
instance Hashable ParseCabal
instance NFData   ParseCabal

type instance RuleResult ParseCabal = ()

cabalRules :: Recorder (WithPriority Log) -> Rules ()
cabalRules :: Recorder (WithPriority Log) -> Rules ()
cabalRules Recorder (WithPriority Log)
recorder = do
  -- Make sure we initialise the cabal files-of-interest.
  Recorder (WithPriority Log) -> Rules ()
ofInterestRules Recorder (WithPriority Log)
recorder
  -- Rule to produce diagnostics for cabal files.
  forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \ParseCabal
ParseCabal NormalizedFilePath
file -> do
    -- whenever this key is marked as dirty (e.g., when a user writes stuff to it),
    -- we rerun this rule because this rule *depends* on GetModificationTime.
    (FileVersion
t, Maybe Text
mCabalSource) <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetFileContents
GetFileContents NormalizedFilePath
file
    Priority -> Log -> Action ()
log' Priority
Debug forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> FileVersion -> Log
LogModificationTime NormalizedFilePath
file FileVersion
t
    ByteString
contents <- case Maybe Text
mCabalSource of
      Just Text
sources -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Encoding.encodeUtf8 Text
sources
      Maybe Text
Nothing -> do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BS.readFile forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
file

    ([PWarning]
pWarnings, Either (Maybe Version, NonEmpty PError) GenericPackageDescription
pm) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ByteString
-> IO
     ([PWarning],
      Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
Parse.parseCabalFileContents ByteString
contents
    let warningDiags :: [FileDiagnostic]
warningDiags = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NormalizedFilePath -> PWarning -> FileDiagnostic
Diagnostics.warningDiagnostic NormalizedFilePath
file) [PWarning]
pWarnings
    case Either (Maybe Version, NonEmpty PError) GenericPackageDescription
pm of
      Left (Maybe Version
_cabalVersion, NonEmpty PError
pErrorNE) -> do
        let errorDiags :: [FileDiagnostic]
errorDiags = forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (NormalizedFilePath -> PError -> FileDiagnostic
Diagnostics.errorDiagnostic NormalizedFilePath
file) NonEmpty PError
pErrorNE
            allDiags :: [FileDiagnostic]
allDiags = [FileDiagnostic]
errorDiags forall a. Semigroup a => a -> a -> a
<> [FileDiagnostic]
warningDiags
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
allDiags, forall a. Maybe a
Nothing)
      Right GenericPackageDescription
_ -> do
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
warningDiags, forall a. a -> Maybe a
Just ())

  forall a. Action a -> Rules ()
action forall a b. (a -> b) -> a -> b
$ do
    -- Run the cabal kick. This code always runs when 'shakeRestart' is run.
    -- Must be careful to not impede the performance too much. Crucial to
    -- a snappy IDE experience.
    Action ()
kick
  where
    log' :: Priority -> Log -> Action ()
log' = forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder

-- | This is the kick function for the cabal plugin.
-- We run this action, whenever we shake session us run/restarted, which triggers
-- actions to produce diagnostics for cabal files.
--
-- It is paramount that this kick-function can be run quickly, since it is a blocking
-- function invocation.
kick :: Action ()
kick :: Action ()
kick = do
  [NormalizedFilePath]
files <- forall k v. HashMap k v -> [k]
HashMap.keys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action (HashMap NormalizedFilePath FileOfInterestStatus)
getCabalFilesOfInterestUntracked
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses ParseCabal
ParseCabal [NormalizedFilePath]
files

-- ----------------------------------------------------------------
-- Code Actions
-- ----------------------------------------------------------------

licenseSuggestCodeAction
  :: IdeState
  -> PluginId
  -> CodeActionParams
  -> LspM Config (Either ResponseError (ResponseResult 'TextDocumentCodeAction))
licenseSuggestCodeAction :: IdeState
-> PluginId
-> CodeActionParams
-> LspM
     Config
     (Either ResponseError (ResponseResult 'TextDocumentCodeAction))
licenseSuggestCodeAction IdeState
_ PluginId
_ (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ (TextDocumentIdentifier Uri
uri) Range
_range CodeActionContext{$sel:_diagnostics:CodeActionContext :: CodeActionContext -> List Diagnostic
_diagnostics=List [Diagnostic]
diags}) =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
List forall a b. (a -> b) -> a -> b
$ [Diagnostic]
diags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> a |? b
InR forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Diagnostic -> [CodeAction]
LicenseSuggest.licenseErrorAction Uri
uri))

-- ----------------------------------------------------------------
-- Cabal file of Interest rules and global variable
-- ----------------------------------------------------------------

-- | Cabal files that are currently open in the lsp-client.
-- Specific actions happen when these files are saved, closed or modified,
-- such as generating diagnostics, re-parsing, etc...
--
-- We need to store the open files to parse them again if we restart the shake session.
-- Restarting of the shake session happens whenever these files are modified.
newtype OfInterestCabalVar = OfInterestCabalVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))

instance Shake.IsIdeGlobal OfInterestCabalVar

data IsCabalFileOfInterest = IsCabalFileOfInterest
    deriving (IsCabalFileOfInterest -> IsCabalFileOfInterest -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IsCabalFileOfInterest -> IsCabalFileOfInterest -> Bool
$c/= :: IsCabalFileOfInterest -> IsCabalFileOfInterest -> Bool
== :: IsCabalFileOfInterest -> IsCabalFileOfInterest -> Bool
$c== :: IsCabalFileOfInterest -> IsCabalFileOfInterest -> Bool
Eq, Int -> IsCabalFileOfInterest -> ShowS
[IsCabalFileOfInterest] -> ShowS
IsCabalFileOfInterest -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [IsCabalFileOfInterest] -> ShowS
$cshowList :: [IsCabalFileOfInterest] -> ShowS
show :: IsCabalFileOfInterest -> [Char]
$cshow :: IsCabalFileOfInterest -> [Char]
showsPrec :: Int -> IsCabalFileOfInterest -> ShowS
$cshowsPrec :: Int -> IsCabalFileOfInterest -> ShowS
Show, Typeable, forall x. Rep IsCabalFileOfInterest x -> IsCabalFileOfInterest
forall x. IsCabalFileOfInterest -> Rep IsCabalFileOfInterest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IsCabalFileOfInterest x -> IsCabalFileOfInterest
$cfrom :: forall x. IsCabalFileOfInterest -> Rep IsCabalFileOfInterest x
Generic)
instance Hashable IsCabalFileOfInterest
instance NFData   IsCabalFileOfInterest

type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult

data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus
  deriving (CabalFileOfInterestResult -> CabalFileOfInterestResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CabalFileOfInterestResult -> CabalFileOfInterestResult -> Bool
$c/= :: CabalFileOfInterestResult -> CabalFileOfInterestResult -> Bool
== :: CabalFileOfInterestResult -> CabalFileOfInterestResult -> Bool
$c== :: CabalFileOfInterestResult -> CabalFileOfInterestResult -> Bool
Eq, Int -> CabalFileOfInterestResult -> ShowS
[CabalFileOfInterestResult] -> ShowS
CabalFileOfInterestResult -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CabalFileOfInterestResult] -> ShowS
$cshowList :: [CabalFileOfInterestResult] -> ShowS
show :: CabalFileOfInterestResult -> [Char]
$cshow :: CabalFileOfInterestResult -> [Char]
showsPrec :: Int -> CabalFileOfInterestResult -> ShowS
$cshowsPrec :: Int -> CabalFileOfInterestResult -> ShowS
Show, Typeable, forall x.
Rep CabalFileOfInterestResult x -> CabalFileOfInterestResult
forall x.
CabalFileOfInterestResult -> Rep CabalFileOfInterestResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep CabalFileOfInterestResult x -> CabalFileOfInterestResult
$cfrom :: forall x.
CabalFileOfInterestResult -> Rep CabalFileOfInterestResult x
Generic)
instance Hashable CabalFileOfInterestResult
instance NFData   CabalFileOfInterestResult

-- | The rule that initialises the files of interest state.
--
-- Needs to be run on start-up.
ofInterestRules :: Recorder (WithPriority Log) -> Rules ()
ofInterestRules :: Recorder (WithPriority Log) -> Rules ()
ofInterestRules Recorder (WithPriority Log)
recorder = do
    forall a. IsIdeGlobal a => a -> Rules ()
Shake.addIdeGlobal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var (HashMap NormalizedFilePath FileOfInterestStatus)
-> OfInterestCabalVar
OfInterestCabalVar forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. a -> IO (Var a)
newVar forall k v. HashMap k v
HashMap.empty)
    forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
Shake.defineEarlyCutoff (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics forall a b. (a -> b) -> a -> b
$ \IsCabalFileOfInterest
IsCabalFileOfInterest NormalizedFilePath
f -> do
        Action ()
alwaysRerun
        HashMap NormalizedFilePath FileOfInterestStatus
filesOfInterest <- Action (HashMap NormalizedFilePath FileOfInterestStatus)
getCabalFilesOfInterestUntracked
        let foi :: CabalFileOfInterestResult
foi = forall b a. b -> (a -> b) -> Maybe a -> b
maybe CabalFileOfInterestResult
NotCabalFOI FileOfInterestStatus -> CabalFileOfInterestResult
IsCabalFOI forall a b. (a -> b) -> a -> b
$ NormalizedFilePath
f forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HashMap.lookup` HashMap NormalizedFilePath FileOfInterestStatus
filesOfInterest
            fp :: ByteString
fp  = CabalFileOfInterestResult -> ByteString
summarize CabalFileOfInterestResult
foi
            res :: (Maybe ByteString, Maybe CabalFileOfInterestResult)
res = (forall a. a -> Maybe a
Just ByteString
fp, forall a. a -> Maybe a
Just CabalFileOfInterestResult
foi)
        forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString, Maybe CabalFileOfInterestResult)
res
    where
    summarize :: CabalFileOfInterestResult -> ByteString
summarize CabalFileOfInterestResult
NotCabalFOI                   = Word8 -> ByteString
BS.singleton Word8
0
    summarize (IsCabalFOI FileOfInterestStatus
OnDisk)           = Word8 -> ByteString
BS.singleton Word8
1
    summarize (IsCabalFOI (Modified Bool
False)) = Word8 -> ByteString
BS.singleton Word8
2
    summarize (IsCabalFOI (Modified Bool
True))  = Word8 -> ByteString
BS.singleton Word8
3

getCabalFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus)
getCabalFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus)
getCabalFilesOfInterestUntracked = do
    OfInterestCabalVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var <- forall a. (HasCallStack, IsIdeGlobal a) => Action a
Shake.getIdeGlobalAction
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Var a -> IO a
readVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var

addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest :: Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest Recorder (WithPriority Log)
recorder IdeState
state NormalizedFilePath
f FileOfInterestStatus
v = do
    OfInterestCabalVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var <- forall a. IsIdeGlobal a => IdeState -> IO a
Shake.getIdeGlobalState IdeState
state
    (Maybe FileOfInterestStatus
prev, HashMap NormalizedFilePath FileOfInterestStatus
files) <- forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var forall a b. (a -> b) -> a -> b
$ \HashMap NormalizedFilePath FileOfInterestStatus
dict -> do
        let (Maybe FileOfInterestStatus
prev, HashMap NormalizedFilePath FileOfInterestStatus
new) = forall (f :: * -> *) k v.
(Functor f, Eq k, Hashable k) =>
(Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)
HashMap.alterF (, forall a. a -> Maybe a
Just FileOfInterestStatus
v) NormalizedFilePath
f HashMap NormalizedFilePath FileOfInterestStatus
dict
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap NormalizedFilePath FileOfInterestStatus
new, (Maybe FileOfInterestStatus
prev, HashMap NormalizedFilePath FileOfInterestStatus
new))
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe FileOfInterestStatus
prev forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just FileOfInterestStatus
v) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall k.
ShakeValue k =>
ShakeExtras -> k -> [NormalizedFilePath] -> STM (IO ())
Shake.recordDirtyKeys (IdeState -> ShakeExtras
shakeExtras IdeState
state) IsFileOfInterest
IsFileOfInterest [NormalizedFilePath
f]
        Priority -> Log -> IO ()
log' Priority
Debug forall a b. (a -> b) -> a -> b
$ HashMap NormalizedFilePath FileOfInterestStatus -> Log
LogFOI HashMap NormalizedFilePath FileOfInterestStatus
files
  where
    log' :: Priority -> Log -> IO ()
log' = forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder

deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO ()
deleteFileOfInterest :: Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> IO ()
deleteFileOfInterest Recorder (WithPriority Log)
recorder IdeState
state NormalizedFilePath
f = do
    OfInterestCabalVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var <- forall a. IsIdeGlobal a => IdeState -> IO a
Shake.getIdeGlobalState IdeState
state
    HashMap NormalizedFilePath FileOfInterestStatus
files <- forall a. Var a -> (a -> a) -> IO a
modifyVar' Var (HashMap NormalizedFilePath FileOfInterestStatus)
var forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HashMap.delete NormalizedFilePath
f
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall k.
ShakeValue k =>
ShakeExtras -> k -> [NormalizedFilePath] -> STM (IO ())
Shake.recordDirtyKeys (IdeState -> ShakeExtras
shakeExtras IdeState
state) IsFileOfInterest
IsFileOfInterest [NormalizedFilePath
f]
    Priority -> Log -> IO ()
log' Priority
Debug forall a b. (a -> b) -> a -> b
$ HashMap NormalizedFilePath FileOfInterestStatus -> Log
LogFOI HashMap NormalizedFilePath FileOfInterestStatus
files
  where
    log' :: Priority -> Log -> IO ()
log' = forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder