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

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

import           Control.Concurrent.Strict
import           Control.DeepSeq
import           Control.Lens                                ((^.))
import           Control.Monad.Extra
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class
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                       (Key, alwaysRerun)
import qualified Development.IDE.Plugin.Completions.Logic    as Ghcide
import qualified Development.IDE.Plugin.Completions.Types    as Ghcide
import           Development.IDE.Types.Shake                 (toKey)
import qualified Distribution.Fields                         as Syntax
import qualified Distribution.Parsec.Position                as Syntax
import           GHC.Generics
import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes
import qualified Ide.Plugin.Cabal.Completion.Completions     as Completions
import           Ide.Plugin.Cabal.Completion.Types           (ParseCabalFields (..),
                                                              ParseCabalFile (..))
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           Ide.Plugin.Cabal.Orphans                    ()
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 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 ann. Context -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty 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
                  ShakeExtras
-> VFS -> NormalizedFilePath -> [Char] -> IO [Key] -> IO ()
restartCabalShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
ide) VFS
vfs NormalizedFilePath
file [Char]
"(opened)" (IO [Key] -> IO ()) -> IO [Key] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> FileOfInterestStatus
-> IO [Key]
addFileOfInterest Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file Modified{firstOpen :: Bool
firstOpen = Bool
True}
          , 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
                  ShakeExtras
-> VFS -> NormalizedFilePath -> [Char] -> IO [Key] -> IO ()
restartCabalShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
ide) VFS
vfs NormalizedFilePath
file [Char]
"(changed)" (IO [Key] -> IO ()) -> IO [Key] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> FileOfInterestStatus
-> IO [Key]
addFileOfInterest Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file Modified{firstOpen :: Bool
firstOpen = Bool
False}
          , 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
                  ShakeExtras
-> VFS -> NormalizedFilePath -> [Char] -> IO [Key] -> IO ()
restartCabalShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
ide) VFS
vfs NormalizedFilePath
file [Char]
"(saved)" (IO [Key] -> IO ()) -> IO [Key] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> FileOfInterestStatus
-> IO [Key]
addFileOfInterest Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file FileOfInterestStatus
OnDisk
          , 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
                  ShakeExtras
-> VFS -> NormalizedFilePath -> [Char] -> IO [Key] -> IO ()
restartCabalShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
ide) VFS
vfs NormalizedFilePath
file [Char]
"(closed)" (IO [Key] -> IO ()) -> IO [Key] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> IO [Key]
deleteFileOfInterest Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file
          ]
    , 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 [Key] -> IO ()
restartCabalShakeSession :: ShakeExtras
-> VFS -> NormalizedFilePath -> [Char] -> IO [Key] -> IO ()
restartCabalShakeSession ShakeExtras
shakeExtras VFS
vfs NormalizedFilePath
file [Char]
actionMsg IO [Key]
actionBetweenSession = do
  ShakeExtras
-> VFSModified -> [Char] -> [DelayedAction ()] -> IO [Key] -> 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) [] (IO [Key] -> IO ()) -> IO [Key] -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Key]
keys <- IO [Key]
actionBetweenSession
    [Key] -> IO [Key]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (GetModificationTime -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey GetModificationTime
GetModificationTime NormalizedFilePath
fileKey -> [Key] -> [Key]
forall a. a -> [a] -> [a]
:[Key]
keys)

-- ----------------------------------------------------------------
-- 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)
-> (ParseCabalFields
    -> NormalizedFilePath -> Action (IdeResult [Field Position]))
-> 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) ((ParseCabalFields
  -> NormalizedFilePath -> Action (IdeResult [Field Position]))
 -> Rules ())
-> (ParseCabalFields
    -> NormalizedFilePath -> Action (IdeResult [Field Position]))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \ParseCabalFields
ParseCabalFields 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 [Field Position] -> Action (IdeResult [Field Position])
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Maybe [Field Position]
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

        case NormalizedFilePath
-> ByteString -> Either FileDiagnostic [Field Position]
Parse.readCabalFields NormalizedFilePath
file ByteString
contents of
          Left FileDiagnostic
_ ->
            IdeResult [Field Position] -> Action (IdeResult [Field Position])
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Maybe [Field Position]
forall a. Maybe a
Nothing)
          Right [Field Position]
fields ->
            IdeResult [Field Position] -> Action (IdeResult [Field Position])
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [Field Position] -> Maybe [Field Position]
forall a. a -> Maybe a
Just [Field Position]
fields)

  Recorder (WithPriority Log)
-> (ParseCabalFile
    -> 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) ((ParseCabalFile
  -> NormalizedFilePath
  -> Action (IdeResult GenericPackageDescription))
 -> Rules ())
-> (ParseCabalFile
    -> NormalizedFilePath
    -> Action (IdeResult GenericPackageDescription))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \ParseCabalFile
ParseCabalFile 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

        -- Instead of fully reparsing the sources to get a 'GenericPackageDescription',
        -- we would much rather re-use the already parsed results of 'ParseCabalFields'.
        -- Unfortunately, Cabal-syntax doesn't expose the function 'parseGenericPackageDescription''
        -- which allows us to resume the parsing pipeline with '[Field Position]'.
        ([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
$ ParseCabalFile
-> [NormalizedFilePath] -> Action [Maybe GenericPackageDescription]
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses ParseCabalFile
Types.ParseCabalFile [NormalizedFilePath]
files

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

licenseSuggestCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
licenseSuggestCodeAction :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
licenseSuggestCodeAction IdeState
ideState PluginId
_ (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ (TextDocumentIdentifier Uri
uri) Range
_range CodeActionContext{$sel:_diagnostics:CodeActionContext :: CodeActionContext -> [Diagnostic]
_diagnostics=[Diagnostic]
diags}) = do
  Int
maxCompls <- (Config -> Int)
-> ExceptT PluginError (HandlerM Config) Config
-> ExceptT PluginError (HandlerM Config) Int
forall a b.
(a -> b)
-> ExceptT PluginError (HandlerM Config) a
-> ExceptT PluginError (HandlerM Config) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Config -> Int
maxCompletions (ExceptT PluginError (HandlerM Config) Config
 -> ExceptT PluginError (HandlerM Config) Int)
-> (IO Config -> ExceptT PluginError (HandlerM Config) Config)
-> IO Config
-> ExceptT PluginError (HandlerM Config) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Config -> ExceptT PluginError (HandlerM Config) Config
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> ExceptT PluginError (HandlerM Config) Int)
-> IO Config -> ExceptT PluginError (HandlerM Config) Int
forall a b. (a -> b) -> a -> b
$ [Char] -> IdeState -> Action Config -> IO Config
forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"cabal-plugin.suggestLicense" IdeState
ideState Action Config
getClientConfigAction
  ([Command |? CodeAction] |? Null)
-> ExceptT
     PluginError (HandlerM Config) ([Command |? CodeAction] |? Null)
forall a. a -> ExceptT PluginError (HandlerM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Command |? CodeAction] |? Null)
 -> ExceptT
      PluginError (HandlerM Config) ([Command |? CodeAction] |? Null))
-> ([Command |? CodeAction] |? Null)
-> ExceptT
     PluginError (HandlerM Config) ([Command |? CodeAction] |? Null)
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
. Int -> Uri -> Diagnostic -> [CodeAction]
LicenseSuggest.licenseErrorAction Int
maxCompls 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 [Key]
addFileOfInterest :: Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> FileOfInterestStatus
-> IO [Key]
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))
  if 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
    then do
        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
        [Key] -> IO [Key]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [IsCabalFileOfInterest -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey IsCabalFileOfInterest
IsCabalFileOfInterest NormalizedFilePath
f]
    else [Key] -> IO [Key]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
 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 [Key]
deleteFileOfInterest :: Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> IO [Key]
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
  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
  [Key] -> IO [Key]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [IsFileOfInterest -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey IsFileOfInterest
IsFileOfInterest NormalizedFilePath
f]
 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) = MessageParams 'Method_TextDocumentCompletion
CompletionParams
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 = MessageParams 'Method_TextDocumentCompletion
CompletionParams
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
mVf <- HandlerM Config (Maybe VirtualFile)
-> ExceptT PluginError (HandlerM 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 (HandlerM Config (Maybe VirtualFile)
 -> ExceptT PluginError (HandlerM Config) (Maybe VirtualFile))
-> HandlerM Config (Maybe VirtualFile)
-> ExceptT PluginError (HandlerM Config) (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ NormalizedUri -> HandlerM Config (Maybe VirtualFile)
forall config. NormalizedUri -> HandlerM config (Maybe VirtualFile)
pluginGetVirtualFile (NormalizedUri -> HandlerM Config (Maybe VirtualFile))
-> NormalizedUri -> HandlerM Config (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri
  case (,) (VirtualFile -> [Char] -> (VirtualFile, [Char]))
-> Maybe VirtualFile -> Maybe ([Char] -> (VirtualFile, [Char]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe VirtualFile
mVf Maybe ([Char] -> (VirtualFile, [Char]))
-> Maybe [Char] -> Maybe (VirtualFile, [Char])
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Uri -> Maybe [Char]
uriToFilePath' Uri
uri of
    Just (VirtualFile
cnts, [Char]
path) -> do
      -- We decide on `useWithStale` here, since `useWithStaleFast` often leads to the wrong completions being suggested.
      -- In case it fails, we still will get some completion results instead of an error.
      Maybe ([Field Position], PositionMapping)
mFields <- IO (Maybe ([Field Position], PositionMapping))
-> ExceptT
     PluginError
     (HandlerM Config)
     (Maybe ([Field Position], PositionMapping))
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ([Field Position], PositionMapping))
 -> ExceptT
      PluginError
      (HandlerM Config)
      (Maybe ([Field Position], PositionMapping)))
-> IO (Maybe ([Field Position], PositionMapping))
-> ExceptT
     PluginError
     (HandlerM Config)
     (Maybe ([Field Position], PositionMapping))
forall a b. (a -> b) -> a -> b
$ [Char]
-> IdeState
-> Action (Maybe ([Field Position], PositionMapping))
-> IO (Maybe ([Field Position], PositionMapping))
forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"cabal-plugin.fields" IdeState
ide (Action (Maybe ([Field Position], PositionMapping))
 -> IO (Maybe ([Field Position], PositionMapping)))
-> Action (Maybe ([Field Position], PositionMapping))
-> IO (Maybe ([Field Position], PositionMapping))
forall a b. (a -> b) -> a -> b
$ ParseCabalFields
-> NormalizedFilePath
-> Action (Maybe ([Field Position], PositionMapping))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale ParseCabalFields
ParseCabalFields (NormalizedFilePath
 -> Action (Maybe ([Field Position], PositionMapping)))
-> NormalizedFilePath
-> Action (Maybe ([Field Position], PositionMapping))
forall a b. (a -> b) -> a -> b
$ [Char] -> NormalizedFilePath
toNormalizedFilePath [Char]
path
      case Maybe ([Field Position], PositionMapping)
mFields of
        Maybe ([Field Position], PositionMapping)
Nothing ->
          ([CompletionItem] |? (CompletionList |? Null))
-> ExceptT
     PluginError
     (HandlerM Config)
     ([CompletionItem] |? (CompletionList |? Null))
forall a. a -> ExceptT PluginError (HandlerM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([CompletionItem] |? (CompletionList |? Null))
 -> ExceptT
      PluginError
      (HandlerM Config)
      ([CompletionItem] |? (CompletionList |? Null)))
-> ((CompletionList |? Null)
    -> [CompletionItem] |? (CompletionList |? Null))
-> (CompletionList |? Null)
-> ExceptT
     PluginError
     (HandlerM 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
      (HandlerM Config)
      ([CompletionItem] |? (CompletionList |? Null)))
-> (CompletionList |? Null)
-> ExceptT
     PluginError
     (HandlerM Config)
     ([CompletionItem] |? (CompletionList |? Null))
forall a b. (a -> b) -> a -> b
$ Null -> CompletionList |? Null
forall a b. b -> a |? b
InR Null
Null
        Just ([Field Position]
fields, PositionMapping
_) -> do
          let pref :: PosPrefixInfo
pref = Position -> VirtualFile -> PosPrefixInfo
Ghcide.getCompletionPrefix Position
position VirtualFile
cnts
          let res :: IO [CompletionItem]
res = PosPrefixInfo -> [Char] -> [Field Position] -> IO [CompletionItem]
produceCompletions PosPrefixInfo
pref [Char]
path [Field Position]
fields
          IO ([CompletionItem] |? (CompletionList |? Null))
-> ExceptT
     PluginError
     (HandlerM Config)
     ([CompletionItem] |? (CompletionList |? Null))
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([CompletionItem] |? (CompletionList |? Null))
 -> ExceptT
      PluginError
      (HandlerM Config)
      ([CompletionItem] |? (CompletionList |? Null)))
-> IO ([CompletionItem] |? (CompletionList |? Null))
-> ExceptT
     PluginError
     (HandlerM 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, [Char])
Nothing -> ([CompletionItem] |? (CompletionList |? Null))
-> ExceptT
     PluginError
     (HandlerM Config)
     ([CompletionItem] |? (CompletionList |? Null))
forall a. a -> ExceptT PluginError (HandlerM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([CompletionItem] |? (CompletionList |? Null))
 -> ExceptT
      PluginError
      (HandlerM Config)
      ([CompletionItem] |? (CompletionList |? Null)))
-> ((CompletionList |? Null)
    -> [CompletionItem] |? (CompletionList |? Null))
-> (CompletionList |? Null)
-> ExceptT
     PluginError
     (HandlerM 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
      (HandlerM Config)
      ([CompletionItem] |? (CompletionList |? Null)))
-> (CompletionList |? Null)
-> ExceptT
     PluginError
     (HandlerM Config)
     ([CompletionItem] |? (CompletionList |? Null))
forall a b. (a -> b) -> a -> b
$ Null -> CompletionList |? Null
forall a b. b -> a |? b
InR Null
Null
 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

  produceCompletions :: Ghcide.PosPrefixInfo -> FilePath -> [Syntax.Field Syntax.Position] -> IO [CompletionItem]
  produceCompletions :: PosPrefixInfo -> [Char] -> [Field Position] -> IO [CompletionItem]
produceCompletions PosPrefixInfo
prefix [Char]
fp [Field Position]
fields = do
    MaybeT IO Context -> IO (Maybe Context)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT ([Field Position] -> MaybeT IO Context
context [Field Position]
fields) 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
                -- We decide on useWithStaleFast here, since we mostly care about the file's meta information,
                -- thus, a quick response gives us the desired result most of the time.
                -- The `withStale` option is very important here, since we often call this rule with invalid cabal files.
                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
$ ParseCabalFile
-> NormalizedFilePath
-> IdeAction (Maybe (GenericPackageDescription, PositionMapping))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping))
useWithStaleFast ParseCabalFile
ParseCabalFile (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
    pos :: Position
pos = PosPrefixInfo -> Position
Ghcide.cursorPos PosPrefixInfo
prefix
    context :: [Field Position] -> MaybeT IO Context
context [Field Position]
fields = Recorder (WithPriority Log)
-> CabalPrefixInfo -> [Field Position] -> MaybeT IO Context
forall (m :: * -> *).
MonadIO m =>
Recorder (WithPriority Log)
-> CabalPrefixInfo -> [Field Position] -> m Context
Completions.getContext Recorder (WithPriority Log)
completerRecorder CabalPrefixInfo
prefInfo [Field Position]
fields
    prefInfo :: CabalPrefixInfo
prefInfo = [Char] -> PosPrefixInfo -> CabalPrefixInfo
Completions.getCabalPrefixInfo [Char]
fp PosPrefixInfo
prefix