{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeFamilies          #-}

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

import           Control.Concurrent.STM
import           Control.Concurrent.Strict
import           Control.DeepSeq
import           Control.Lens                                ((^.))
import           Control.Monad.Extra
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class                   (lift)
import           Control.Monad.Trans.Maybe                   (runMaybeT)
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 qualified Development.IDE.Plugin.Completions.Logic    as Ghcide
import qualified Development.IDE.Plugin.Completions.Types    as Ghcide
import           GHC.Generics
import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes
import qualified Ide.Plugin.Cabal.Completion.Completions     as Completions
import qualified Ide.Plugin.Cabal.Completion.Types           as Types
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.Types
import qualified Language.LSP.Protocol.Lens                  as JL
import qualified Language.LSP.Protocol.Message               as LSP
import           Language.LSP.Protocol.Types
import           Language.LSP.Server                         (getVirtualFile)
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)
  | LogCompletionContext Types.Context Position
  | LogCompletions Types.Log
  deriving (Int -> Log -> ShowS
[Log] -> ShowS
Log -> [Char]
(Int -> Log -> ShowS)
-> (Log -> [Char]) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Log -> ShowS
showsPrec :: Int -> Log -> ShowS
$cshow :: Log -> [Char]
show :: Log -> [Char]
$cshowList :: [Log] -> ShowS
showList :: [Log] -> ShowS
Show)

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogShake Log
log' -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
log'
    LogModificationTime NormalizedFilePath
nfp FileVersion
modTime ->
      Doc ann
"Modified:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
nfp) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FileVersion -> [Char]
forall a. Show a => a -> [Char]
show FileVersion
modTime)
    LogDocOpened Uri
uri ->
      Doc ann
"Opened text document:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Uri -> Text
getUri Uri
uri)
    LogDocModified Uri
uri ->
      Doc ann
"Modified text document:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Uri -> Text
getUri Uri
uri)
    LogDocSaved Uri
uri ->
      Doc ann
"Saved text document:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Uri -> Text
getUri Uri
uri)
    LogDocClosed Uri
uri ->
      Doc ann
"Closed text document:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> 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:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> HashMap NormalizedFilePath FileOfInterestStatus -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow HashMap NormalizedFilePath FileOfInterestStatus
files
    LogCompletionContext Context
context Position
position ->
      Doc ann
"Determined completion context:"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Context -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Context
context
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"for cursor position:"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Position -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Position -> Doc ann
pretty Position
position
    LogCompletions Log
logs -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
logs

descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
plId =
  (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultCabalPluginDescriptor PluginId
plId Text
"Provides a variety of IDE features in cabal files")
    { pluginRules = cabalRules recorder plId
    , pluginHandlers =
        mconcat
          [ mkPluginHandler LSP.SMethod_TextDocumentCodeAction licenseSuggestCodeAction
          , mkPluginHandler LSP.SMethod_TextDocumentCompletion $ completion recorder
          ]
    , pluginNotificationHandlers =
        mconcat
          [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $
              \IdeState
ide VFS
vfs PluginId
_ (DidOpenTextDocumentParams TextDocumentItem{Uri
_uri :: Uri
$sel:_uri:TextDocumentItem :: TextDocumentItem -> Uri
_uri, Int32
_version :: Int32
$sel:_version:TextDocumentItem :: TextDocumentItem -> Int32
_version}) -> IO () -> LspT Config IO ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspT Config IO ()) -> IO () -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ do
                Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri ((NormalizedFilePath -> IO ()) -> IO ())
-> (NormalizedFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
                  Priority -> Log -> IO ()
log' Priority
Debug (Log -> IO ()) -> Log -> IO ()
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)"
          , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $
              \IdeState
ide VFS
vfs PluginId
_ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{Uri
_uri :: Uri
$sel:_uri:VersionedTextDocumentIdentifier :: VersionedTextDocumentIdentifier -> Uri
_uri} [TextDocumentContentChangeEvent]
_) -> IO () -> LspT Config IO ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspT Config IO ()) -> IO () -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ do
                Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri ((NormalizedFilePath -> IO ()) -> IO ())
-> (NormalizedFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
                  Priority -> Log -> IO ()
log' Priority
Debug (Log -> IO ()) -> Log -> IO ()
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)"
          , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $
              \IdeState
ide VFS
vfs PluginId
_ (DidSaveTextDocumentParams TextDocumentIdentifier{Uri
_uri :: Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri} Maybe Text
_) -> IO () -> LspT Config IO ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspT Config IO ()) -> IO () -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ do
                Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri ((NormalizedFilePath -> IO ()) -> IO ())
-> (NormalizedFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
                  Priority -> Log -> IO ()
log' Priority
Debug (Log -> IO ()) -> Log -> IO ()
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)"
          , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $
              \IdeState
ide VFS
vfs PluginId
_ (DidCloseTextDocumentParams TextDocumentIdentifier{Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri}) -> IO () -> LspT Config IO ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspT Config IO ()) -> IO () -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ do
                Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri ((NormalizedFilePath -> IO ()) -> IO ())
-> (NormalizedFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
                  Priority -> Log -> IO ()
log' Priority
Debug (Log -> IO ()) -> Log -> IO ()
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)"
          ]
    , pluginConfigDescriptor = defaultConfigDescriptor
      { configHasDiagnostics = True
      }
    }
 where
  log' :: Priority -> Log -> IO ()
log' = Recorder (WithPriority Log) -> Priority -> Log -> IO ()
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 = Maybe [Char] -> ([Char] -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Uri -> Maybe [Char]
uriToFilePath Uri
uri) (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> IO ()
act (NormalizedFilePath -> IO ())
-> ([Char] -> NormalizedFilePath) -> [Char] -> IO ()
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
  IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ ShakeExtras
-> GetModificationTime -> [NormalizedFilePath] -> STM (IO ())
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 [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
actionMsg) []

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

cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules ()
cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules ()
cabalRules Recorder (WithPriority Log)
recorder PluginId
plId = 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.
  Recorder (WithPriority Log)
-> (GetCabalDiagnostics
    -> NormalizedFilePath
    -> Action (IdeResult GenericPackageDescription))
-> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define ((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) ((GetCabalDiagnostics
  -> NormalizedFilePath
  -> Action (IdeResult GenericPackageDescription))
 -> Rules ())
-> (GetCabalDiagnostics
    -> NormalizedFilePath
    -> Action (IdeResult GenericPackageDescription))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \GetCabalDiagnostics
Types.GetCabalDiagnostics NormalizedFilePath
file -> do
    PluginConfig
config <- PluginId -> Action PluginConfig
getPluginConfigAction PluginId
plId
    if Bool -> Bool
not (PluginConfig -> Bool
plcGlobalOn PluginConfig
config Bool -> Bool -> Bool
&& PluginConfig -> Bool
plcDiagnosticsOn PluginConfig
config)
        then IdeResult GenericPackageDescription
-> Action (IdeResult GenericPackageDescription)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Maybe GenericPackageDescription
forall a. Maybe a
Nothing)
        else 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) <- GetFileContents
-> NormalizedFilePath -> Action (FileVersion, Maybe Text)
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetFileContents
GetFileContents NormalizedFilePath
file
          Priority -> Log -> Action ()
log' Priority
Debug (Log -> Action ()) -> Log -> Action ()
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 ->
              ByteString -> Action ByteString
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Action ByteString)
-> ByteString -> Action ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Encoding.encodeUtf8 Text
sources
            Maybe Text
Nothing -> do
              IO ByteString -> Action ByteString
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Action ByteString)
-> IO ByteString -> Action ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BS.readFile ([Char] -> IO ByteString) -> [Char] -> IO ByteString
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
file

          ([PWarning]
pWarnings, Either (Maybe Version, NonEmpty PError) GenericPackageDescription
pm) <- IO
  ([PWarning],
   Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
-> Action
     ([PWarning],
      Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
 -> Action
      ([PWarning],
       Either (Maybe Version, NonEmpty PError) GenericPackageDescription))
-> IO
     ([PWarning],
      Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
-> Action
     ([PWarning],
      Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ ByteString
-> IO
     ([PWarning],
      Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
Parse.parseCabalFileContents ByteString
contents
          let warningDiags :: [FileDiagnostic]
warningDiags = (PWarning -> FileDiagnostic) -> [PWarning] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
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 = NonEmpty FileDiagnostic -> [FileDiagnostic]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty FileDiagnostic -> [FileDiagnostic])
-> NonEmpty FileDiagnostic -> [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ (PError -> FileDiagnostic)
-> NonEmpty PError -> NonEmpty FileDiagnostic
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 [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
forall a. Semigroup a => a -> a -> a
<> [FileDiagnostic]
warningDiags
              IdeResult GenericPackageDescription
-> Action (IdeResult GenericPackageDescription)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
allDiags, Maybe GenericPackageDescription
forall a. Maybe a
Nothing)
            Right GenericPackageDescription
gpd -> do
              IdeResult GenericPackageDescription
-> Action (IdeResult GenericPackageDescription)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
warningDiags, GenericPackageDescription -> Maybe GenericPackageDescription
forall a. a -> Maybe a
Just GenericPackageDescription
gpd)

  Action () -> Rules ()
forall a. Action a -> Rules ()
action (Action () -> Rules ()) -> Action () -> Rules ()
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' = Recorder (WithPriority Log) -> Priority -> Log -> Action ()
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 <- HashMap NormalizedFilePath FileOfInterestStatus
-> [NormalizedFilePath]
forall k v. HashMap k v -> [k]
HashMap.keys (HashMap NormalizedFilePath FileOfInterestStatus
 -> [NormalizedFilePath])
-> Action (HashMap NormalizedFilePath FileOfInterestStatus)
-> Action [NormalizedFilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action (HashMap NormalizedFilePath FileOfInterestStatus)
getCabalFilesOfInterestUntracked
  Action [Maybe GenericPackageDescription] -> Action ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Action [Maybe GenericPackageDescription] -> Action ())
-> Action [Maybe GenericPackageDescription] -> Action ()
forall a b. (a -> b) -> a -> b
$ GetCabalDiagnostics
-> [NormalizedFilePath] -> Action [Maybe GenericPackageDescription]
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GetCabalDiagnostics
Types.GetCabalDiagnostics [NormalizedFilePath]
files

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

licenseSuggestCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
licenseSuggestCodeAction :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
licenseSuggestCodeAction IdeState
_ PluginId
_ (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ (TextDocumentIdentifier Uri
uri) Range
_range CodeActionContext{$sel:_diagnostics:CodeActionContext :: CodeActionContext -> [Diagnostic]
_diagnostics=[Diagnostic]
diags}) =
  MessageResult 'Method_TextDocumentCodeAction
-> ExceptT
     PluginError
     (LspM Config)
     (MessageResult 'Method_TextDocumentCodeAction)
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MessageResult 'Method_TextDocumentCodeAction
 -> ExceptT
      PluginError
      (LspM Config)
      (MessageResult 'Method_TextDocumentCodeAction))
-> MessageResult 'Method_TextDocumentCodeAction
-> ExceptT
     PluginError
     (LspM Config)
     (MessageResult 'Method_TextDocumentCodeAction)
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> [Command |? CodeAction] |? Null
forall a b. a -> a |? b
InL ([Command |? CodeAction] -> [Command |? CodeAction] |? Null)
-> [Command |? CodeAction] -> [Command |? CodeAction] |? Null
forall a b. (a -> b) -> a -> b
$ [Diagnostic]
diags [Diagnostic]
-> (Diagnostic -> [Command |? CodeAction])
-> [Command |? CodeAction]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((CodeAction -> Command |? CodeAction)
-> [CodeAction] -> [Command |? CodeAction]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CodeAction -> Command |? CodeAction
forall a b. b -> a |? b
InR ([CodeAction] -> [Command |? CodeAction])
-> (Diagnostic -> [CodeAction])
-> Diagnostic
-> [Command |? CodeAction]
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
(IsCabalFileOfInterest -> IsCabalFileOfInterest -> Bool)
-> (IsCabalFileOfInterest -> IsCabalFileOfInterest -> Bool)
-> Eq IsCabalFileOfInterest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IsCabalFileOfInterest -> IsCabalFileOfInterest -> Bool
== :: IsCabalFileOfInterest -> IsCabalFileOfInterest -> Bool
$c/= :: IsCabalFileOfInterest -> IsCabalFileOfInterest -> Bool
/= :: IsCabalFileOfInterest -> IsCabalFileOfInterest -> Bool
Eq, Int -> IsCabalFileOfInterest -> ShowS
[IsCabalFileOfInterest] -> ShowS
IsCabalFileOfInterest -> [Char]
(Int -> IsCabalFileOfInterest -> ShowS)
-> (IsCabalFileOfInterest -> [Char])
-> ([IsCabalFileOfInterest] -> ShowS)
-> Show IsCabalFileOfInterest
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IsCabalFileOfInterest -> ShowS
showsPrec :: Int -> IsCabalFileOfInterest -> ShowS
$cshow :: IsCabalFileOfInterest -> [Char]
show :: IsCabalFileOfInterest -> [Char]
$cshowList :: [IsCabalFileOfInterest] -> ShowS
showList :: [IsCabalFileOfInterest] -> ShowS
Show, Typeable, (forall x. IsCabalFileOfInterest -> Rep IsCabalFileOfInterest x)
-> (forall x. Rep IsCabalFileOfInterest x -> IsCabalFileOfInterest)
-> Generic IsCabalFileOfInterest
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
$cfrom :: forall x. IsCabalFileOfInterest -> Rep IsCabalFileOfInterest x
from :: forall x. IsCabalFileOfInterest -> Rep IsCabalFileOfInterest x
$cto :: forall x. Rep IsCabalFileOfInterest x -> IsCabalFileOfInterest
to :: forall x. Rep IsCabalFileOfInterest x -> IsCabalFileOfInterest
Generic)
instance Hashable IsCabalFileOfInterest
instance NFData IsCabalFileOfInterest

type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult

data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus
  deriving (CabalFileOfInterestResult -> CabalFileOfInterestResult -> Bool
(CabalFileOfInterestResult -> CabalFileOfInterestResult -> Bool)
-> (CabalFileOfInterestResult -> CabalFileOfInterestResult -> Bool)
-> Eq CabalFileOfInterestResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CabalFileOfInterestResult -> CabalFileOfInterestResult -> Bool
== :: CabalFileOfInterestResult -> CabalFileOfInterestResult -> Bool
$c/= :: CabalFileOfInterestResult -> CabalFileOfInterestResult -> Bool
/= :: CabalFileOfInterestResult -> CabalFileOfInterestResult -> Bool
Eq, Int -> CabalFileOfInterestResult -> ShowS
[CabalFileOfInterestResult] -> ShowS
CabalFileOfInterestResult -> [Char]
(Int -> CabalFileOfInterestResult -> ShowS)
-> (CabalFileOfInterestResult -> [Char])
-> ([CabalFileOfInterestResult] -> ShowS)
-> Show CabalFileOfInterestResult
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CabalFileOfInterestResult -> ShowS
showsPrec :: Int -> CabalFileOfInterestResult -> ShowS
$cshow :: CabalFileOfInterestResult -> [Char]
show :: CabalFileOfInterestResult -> [Char]
$cshowList :: [CabalFileOfInterestResult] -> ShowS
showList :: [CabalFileOfInterestResult] -> ShowS
Show, Typeable, (forall x.
 CabalFileOfInterestResult -> Rep CabalFileOfInterestResult x)
-> (forall x.
    Rep CabalFileOfInterestResult x -> CabalFileOfInterestResult)
-> Generic CabalFileOfInterestResult
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
$cfrom :: forall x.
CabalFileOfInterestResult -> Rep CabalFileOfInterestResult x
from :: forall x.
CabalFileOfInterestResult -> Rep CabalFileOfInterestResult x
$cto :: forall x.
Rep CabalFileOfInterestResult x -> CabalFileOfInterestResult
to :: forall x.
Rep CabalFileOfInterestResult x -> CabalFileOfInterestResult
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
  OfInterestCabalVar -> Rules ()
forall a. IsIdeGlobal a => a -> Rules ()
Shake.addIdeGlobal (OfInterestCabalVar -> Rules ())
-> (Var (HashMap NormalizedFilePath FileOfInterestStatus)
    -> OfInterestCabalVar)
-> Var (HashMap NormalizedFilePath FileOfInterestStatus)
-> Rules ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var (HashMap NormalizedFilePath FileOfInterestStatus)
-> OfInterestCabalVar
OfInterestCabalVar (Var (HashMap NormalizedFilePath FileOfInterestStatus) -> Rules ())
-> Rules (Var (HashMap NormalizedFilePath FileOfInterestStatus))
-> Rules ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Var (HashMap NormalizedFilePath FileOfInterestStatus))
-> Rules (Var (HashMap NormalizedFilePath FileOfInterestStatus))
forall a. IO a -> Rules a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HashMap NormalizedFilePath FileOfInterestStatus
-> IO (Var (HashMap NormalizedFilePath FileOfInterestStatus))
forall a. a -> IO (Var a)
newVar HashMap NormalizedFilePath FileOfInterestStatus
forall k v. HashMap k v
HashMap.empty)
  Recorder (WithPriority Log)
-> RuleBody IsCabalFileOfInterest CabalFileOfInterestResult
-> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
Shake.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 IsCabalFileOfInterest CabalFileOfInterestResult
 -> Rules ())
-> RuleBody IsCabalFileOfInterest CabalFileOfInterestResult
-> Rules ()
forall a b. (a -> b) -> a -> b
$ (IsCabalFileOfInterest
 -> NormalizedFilePath
 -> Action (Maybe ByteString, Maybe CabalFileOfInterestResult))
-> RuleBody IsCabalFileOfInterest CabalFileOfInterestResult
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics ((IsCabalFileOfInterest
  -> NormalizedFilePath
  -> Action (Maybe ByteString, Maybe CabalFileOfInterestResult))
 -> RuleBody IsCabalFileOfInterest CabalFileOfInterestResult)
-> (IsCabalFileOfInterest
    -> NormalizedFilePath
    -> Action (Maybe ByteString, Maybe CabalFileOfInterestResult))
-> RuleBody IsCabalFileOfInterest CabalFileOfInterestResult
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 = CabalFileOfInterestResult
-> (FileOfInterestStatus -> CabalFileOfInterestResult)
-> Maybe FileOfInterestStatus
-> CabalFileOfInterestResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CabalFileOfInterestResult
NotCabalFOI FileOfInterestStatus -> CabalFileOfInterestResult
IsCabalFOI (Maybe FileOfInterestStatus -> CabalFileOfInterestResult)
-> Maybe FileOfInterestStatus -> CabalFileOfInterestResult
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath
f NormalizedFilePath
-> HashMap NormalizedFilePath FileOfInterestStatus
-> Maybe FileOfInterestStatus
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 = (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
fp, CabalFileOfInterestResult -> Maybe CabalFileOfInterestResult
forall a. a -> Maybe a
Just CabalFileOfInterestResult
foi)
    (Maybe ByteString, Maybe CabalFileOfInterestResult)
-> Action (Maybe ByteString, Maybe CabalFileOfInterestResult)
forall a. a -> Action a
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 <- Action OfInterestCabalVar
forall a. (HasCallStack, IsIdeGlobal a) => Action a
Shake.getIdeGlobalAction
  IO (HashMap NormalizedFilePath FileOfInterestStatus)
-> Action (HashMap NormalizedFilePath FileOfInterestStatus)
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HashMap NormalizedFilePath FileOfInterestStatus)
 -> Action (HashMap NormalizedFilePath FileOfInterestStatus))
-> IO (HashMap NormalizedFilePath FileOfInterestStatus)
-> Action (HashMap NormalizedFilePath FileOfInterestStatus)
forall a b. (a -> b) -> a -> b
$ Var (HashMap NormalizedFilePath FileOfInterestStatus)
-> IO (HashMap NormalizedFilePath FileOfInterestStatus)
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 <- IdeState -> IO OfInterestCabalVar
forall a. IsIdeGlobal a => IdeState -> IO a
Shake.getIdeGlobalState IdeState
state
  (Maybe FileOfInterestStatus
prev, HashMap NormalizedFilePath FileOfInterestStatus
files) <- Var (HashMap NormalizedFilePath FileOfInterestStatus)
-> (HashMap NormalizedFilePath FileOfInterestStatus
    -> IO
         (HashMap NormalizedFilePath FileOfInterestStatus,
          (Maybe FileOfInterestStatus,
           HashMap NormalizedFilePath FileOfInterestStatus)))
-> IO
     (Maybe FileOfInterestStatus,
      HashMap NormalizedFilePath FileOfInterestStatus)
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var ((HashMap NormalizedFilePath FileOfInterestStatus
  -> IO
       (HashMap NormalizedFilePath FileOfInterestStatus,
        (Maybe FileOfInterestStatus,
         HashMap NormalizedFilePath FileOfInterestStatus)))
 -> IO
      (Maybe FileOfInterestStatus,
       HashMap NormalizedFilePath FileOfInterestStatus))
-> (HashMap NormalizedFilePath FileOfInterestStatus
    -> IO
         (HashMap NormalizedFilePath FileOfInterestStatus,
          (Maybe FileOfInterestStatus,
           HashMap NormalizedFilePath FileOfInterestStatus)))
-> IO
     (Maybe FileOfInterestStatus,
      HashMap NormalizedFilePath FileOfInterestStatus)
forall a b. (a -> b) -> a -> b
$ \HashMap NormalizedFilePath FileOfInterestStatus
dict -> do
    let (Maybe FileOfInterestStatus
prev, HashMap NormalizedFilePath FileOfInterestStatus
new) = (Maybe FileOfInterestStatus
 -> (Maybe FileOfInterestStatus, Maybe FileOfInterestStatus))
-> NormalizedFilePath
-> HashMap NormalizedFilePath FileOfInterestStatus
-> (Maybe FileOfInterestStatus,
    HashMap NormalizedFilePath FileOfInterestStatus)
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 (,FileOfInterestStatus -> Maybe FileOfInterestStatus
forall a. a -> Maybe a
Just FileOfInterestStatus
v) NormalizedFilePath
f HashMap NormalizedFilePath FileOfInterestStatus
dict
    (HashMap NormalizedFilePath FileOfInterestStatus,
 (Maybe FileOfInterestStatus,
  HashMap NormalizedFilePath FileOfInterestStatus))
-> IO
     (HashMap NormalizedFilePath FileOfInterestStatus,
      (Maybe FileOfInterestStatus,
       HashMap NormalizedFilePath FileOfInterestStatus))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap NormalizedFilePath FileOfInterestStatus
new, (Maybe FileOfInterestStatus
prev, HashMap NormalizedFilePath FileOfInterestStatus
new))
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe FileOfInterestStatus
prev Maybe FileOfInterestStatus -> Maybe FileOfInterestStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= FileOfInterestStatus -> Maybe FileOfInterestStatus
forall a. a -> Maybe a
Just FileOfInterestStatus
v) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ ShakeExtras
-> IsFileOfInterest -> [NormalizedFilePath] -> STM (IO ())
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 (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ HashMap NormalizedFilePath FileOfInterestStatus -> Log
LogFOI HashMap NormalizedFilePath FileOfInterestStatus
files
 where
  log' :: Priority -> Log -> IO ()
log' = Recorder (WithPriority Log) -> Priority -> Log -> IO ()
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 <- IdeState -> IO OfInterestCabalVar
forall a. IsIdeGlobal a => IdeState -> IO a
Shake.getIdeGlobalState IdeState
state
  HashMap NormalizedFilePath FileOfInterestStatus
files <- Var (HashMap NormalizedFilePath FileOfInterestStatus)
-> (HashMap NormalizedFilePath FileOfInterestStatus
    -> HashMap NormalizedFilePath FileOfInterestStatus)
-> IO (HashMap NormalizedFilePath FileOfInterestStatus)
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var (HashMap NormalizedFilePath FileOfInterestStatus)
var ((HashMap NormalizedFilePath FileOfInterestStatus
  -> HashMap NormalizedFilePath FileOfInterestStatus)
 -> IO (HashMap NormalizedFilePath FileOfInterestStatus))
-> (HashMap NormalizedFilePath FileOfInterestStatus
    -> HashMap NormalizedFilePath FileOfInterestStatus)
-> IO (HashMap NormalizedFilePath FileOfInterestStatus)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath
-> HashMap NormalizedFilePath FileOfInterestStatus
-> HashMap NormalizedFilePath FileOfInterestStatus
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HashMap.delete NormalizedFilePath
f
  IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ ShakeExtras
-> IsFileOfInterest -> [NormalizedFilePath] -> STM (IO ())
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 (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ HashMap NormalizedFilePath FileOfInterestStatus -> Log
LogFOI HashMap NormalizedFilePath FileOfInterestStatus
files
 where
  log' :: Priority -> Log -> IO ()
log' = Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder

-- ----------------------------------------------------------------
-- Completion
-- ----------------------------------------------------------------

completion :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion
completion :: Recorder (WithPriority Log)
-> PluginMethodHandler IdeState 'Method_TextDocumentCompletion
completion Recorder (WithPriority Log)
recorder IdeState
ide PluginId
_ MessageParams 'Method_TextDocumentCompletion
complParams = do
  let (TextDocumentIdentifier Uri
uri) = CompletionParams
MessageParams 'Method_TextDocumentCompletion
complParams CompletionParams
-> Getting
     TextDocumentIdentifier CompletionParams TextDocumentIdentifier
-> TextDocumentIdentifier
forall s a. s -> Getting a s a -> a
^. Getting
  TextDocumentIdentifier CompletionParams TextDocumentIdentifier
forall s a. HasTextDocument s a => Lens' s a
Lens' CompletionParams TextDocumentIdentifier
JL.textDocument
      position :: Position
position = CompletionParams
MessageParams 'Method_TextDocumentCompletion
complParams CompletionParams
-> Getting Position CompletionParams Position -> Position
forall s a. s -> Getting a s a -> a
^. Getting Position CompletionParams Position
forall s a. HasPosition s a => Lens' s a
Lens' CompletionParams Position
JL.position
  Maybe VirtualFile
contents <- LspM Config (Maybe VirtualFile)
-> ExceptT PluginError (LspM Config) (Maybe VirtualFile)
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspM Config (Maybe VirtualFile)
 -> ExceptT PluginError (LspM Config) (Maybe VirtualFile))
-> LspM Config (Maybe VirtualFile)
-> ExceptT PluginError (LspM Config) (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ NormalizedUri -> LspM Config (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile (NormalizedUri -> LspM Config (Maybe VirtualFile))
-> NormalizedUri -> LspM Config (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri
  case (Maybe VirtualFile
contents, Uri -> Maybe [Char]
uriToFilePath' Uri
uri) of
    (Just VirtualFile
cnts, Just [Char]
path) -> do
      let pref :: PosPrefixInfo
pref = Position -> VirtualFile -> PosPrefixInfo
Ghcide.getCompletionPrefix Position
position VirtualFile
cnts
      let res :: IO [CompletionItem]
res = PosPrefixInfo -> [Char] -> VirtualFile -> IO [CompletionItem]
result PosPrefixInfo
pref [Char]
path VirtualFile
cnts
      IO ([CompletionItem] |? (CompletionList |? Null))
-> ExceptT
     PluginError
     (LspM Config)
     ([CompletionItem] |? (CompletionList |? Null))
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([CompletionItem] |? (CompletionList |? Null))
 -> ExceptT
      PluginError
      (LspM Config)
      ([CompletionItem] |? (CompletionList |? Null)))
-> IO ([CompletionItem] |? (CompletionList |? Null))
-> ExceptT
     PluginError
     (LspM Config)
     ([CompletionItem] |? (CompletionList |? Null))
forall a b. (a -> b) -> a -> b
$ ([CompletionItem] -> [CompletionItem] |? (CompletionList |? Null))
-> IO [CompletionItem]
-> IO ([CompletionItem] |? (CompletionList |? Null))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [CompletionItem] -> [CompletionItem] |? (CompletionList |? Null)
forall a b. a -> a |? b
InL IO [CompletionItem]
res
    (Maybe VirtualFile, Maybe [Char])
_ -> ([CompletionItem] |? (CompletionList |? Null))
-> ExceptT
     PluginError
     (LspM Config)
     ([CompletionItem] |? (CompletionList |? Null))
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([CompletionItem] |? (CompletionList |? Null))
 -> ExceptT
      PluginError
      (LspM Config)
      ([CompletionItem] |? (CompletionList |? Null)))
-> ((CompletionList |? Null)
    -> [CompletionItem] |? (CompletionList |? Null))
-> (CompletionList |? Null)
-> ExceptT
     PluginError
     (LspM Config)
     ([CompletionItem] |? (CompletionList |? Null))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompletionList |? Null)
-> [CompletionItem] |? (CompletionList |? Null)
forall a b. b -> a |? b
InR ((CompletionList |? Null)
 -> ExceptT
      PluginError
      (LspM Config)
      ([CompletionItem] |? (CompletionList |? Null)))
-> (CompletionList |? Null)
-> ExceptT
     PluginError
     (LspM Config)
     ([CompletionItem] |? (CompletionList |? Null))
forall a b. (a -> b) -> a -> b
$ Null -> CompletionList |? Null
forall a b. b -> a |? b
InR Null
Null
 where
  result :: Ghcide.PosPrefixInfo -> FilePath -> VFS.VirtualFile -> IO [CompletionItem]
  result :: PosPrefixInfo -> [Char] -> VirtualFile -> IO [CompletionItem]
result PosPrefixInfo
prefix [Char]
fp VirtualFile
cnts = do
    MaybeT IO Context -> IO (Maybe Context)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT IO Context
context IO (Maybe Context)
-> (Maybe Context -> IO [CompletionItem]) -> IO [CompletionItem]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Context
Nothing -> [CompletionItem] -> IO [CompletionItem]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      Just Context
ctx -> do
        Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Position -> Log
LogCompletionContext Context
ctx Position
pos
        let completer :: Completer
completer = Context -> Completer
Completions.contextToCompleter Context
ctx
        let completerData :: CompleterData
completerData = CompleterTypes.CompleterData
              { getLatestGPD :: IO (Maybe GenericPackageDescription)
getLatestGPD = do
                Maybe (GenericPackageDescription, PositionMapping)
mGPD <- [Char]
-> ShakeExtras
-> IdeAction (Maybe (GenericPackageDescription, PositionMapping))
-> IO (Maybe (GenericPackageDescription, PositionMapping))
forall a. [Char] -> ShakeExtras -> IdeAction a -> IO a
runIdeAction [Char]
"cabal-plugin.modulesCompleter.gpd" (IdeState -> ShakeExtras
shakeExtras IdeState
ide) (IdeAction (Maybe (GenericPackageDescription, PositionMapping))
 -> IO (Maybe (GenericPackageDescription, PositionMapping)))
-> IdeAction (Maybe (GenericPackageDescription, PositionMapping))
-> IO (Maybe (GenericPackageDescription, PositionMapping))
forall a b. (a -> b) -> a -> b
$ GetCabalDiagnostics
-> NormalizedFilePath
-> IdeAction (Maybe (GenericPackageDescription, PositionMapping))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping))
useWithStaleFast GetCabalDiagnostics
Types.GetCabalDiagnostics (NormalizedFilePath
 -> IdeAction (Maybe (GenericPackageDescription, PositionMapping)))
-> NormalizedFilePath
-> IdeAction (Maybe (GenericPackageDescription, PositionMapping))
forall a b. (a -> b) -> a -> b
$ [Char] -> NormalizedFilePath
toNormalizedFilePath [Char]
fp
                Maybe GenericPackageDescription
-> IO (Maybe GenericPackageDescription)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe GenericPackageDescription
 -> IO (Maybe GenericPackageDescription))
-> Maybe GenericPackageDescription
-> IO (Maybe GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ ((GenericPackageDescription, PositionMapping)
 -> GenericPackageDescription)
-> Maybe (GenericPackageDescription, PositionMapping)
-> Maybe GenericPackageDescription
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GenericPackageDescription, PositionMapping)
-> GenericPackageDescription
forall a b. (a, b) -> a
fst Maybe (GenericPackageDescription, PositionMapping)
mGPD
              , cabalPrefixInfo :: CabalPrefixInfo
cabalPrefixInfo = CabalPrefixInfo
prefInfo
              , stanzaName :: Maybe Text
stanzaName =
                case Context -> StanzaContext
forall a b. (a, b) -> a
fst Context
ctx of
                  Types.Stanza Text
_ Maybe Text
name -> Maybe Text
name
                  StanzaContext
_                   -> Maybe Text
forall a. Maybe a
Nothing
              }
        [CompletionItem]
completions <- Completer
completer Recorder (WithPriority Log)
completerRecorder CompleterData
completerData
        [CompletionItem] -> IO [CompletionItem]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [CompletionItem]
completions
   where
    completerRecorder :: Recorder (WithPriority Log)
completerRecorder = (Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogCompletions Recorder (WithPriority Log)
recorder
    pos :: Position
pos = PosPrefixInfo -> Position
Ghcide.cursorPos PosPrefixInfo
prefix
    context :: MaybeT IO Context
context = Recorder (WithPriority Log)
-> CabalPrefixInfo -> Rope -> MaybeT IO Context
forall (m :: * -> *).
MonadIO m =>
Recorder (WithPriority Log)
-> CabalPrefixInfo -> Rope -> MaybeT m Context
Completions.getContext Recorder (WithPriority Log)
completerRecorder CabalPrefixInfo
prefInfo (VirtualFile
cnts VirtualFile -> Getting Rope VirtualFile Rope -> Rope
forall s a. s -> Getting a s a -> a
^. Getting Rope VirtualFile Rope
forall s a. HasFile_text s a => Lens' s a
Lens' VirtualFile Rope
VFS.file_text)
    prefInfo :: CabalPrefixInfo
prefInfo = [Char] -> PosPrefixInfo -> CabalPrefixInfo
Completions.getCabalPrefixInfo [Char]
fp PosPrefixInfo
prefix