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

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

import           Control.Concurrent.STM
import           Control.Concurrent.Strict
import           Control.DeepSeq
import           Control.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           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]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> [Char]
$cshow :: Log -> [Char]
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show)

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogShake Log
log' -> forall a ann. Pretty a => a -> Doc ann
pretty Log
log'
    LogModificationTime NormalizedFilePath
nfp FileVersion
modTime ->
      Doc ann
"Modified:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
nfp) forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> [Char]
show FileVersion
modTime)
    LogDocOpened Uri
uri ->
      Doc ann
"Opened text document:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (Uri -> Text
getUri Uri
uri)
    LogDocModified Uri
uri ->
      Doc ann
"Modified text document:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (Uri -> Text
getUri Uri
uri)
    LogDocSaved Uri
uri ->
      Doc ann
"Saved text document:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (Uri -> Text
getUri Uri
uri)
    LogDocClosed Uri
uri ->
      Doc ann
"Closed text document:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (Uri -> Text
getUri Uri
uri)
    LogFOI HashMap NormalizedFilePath FileOfInterestStatus
files ->
      Doc ann
"Set files of interest to:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow HashMap NormalizedFilePath FileOfInterestStatus
files
    LogCompletionContext Context
context Position
position ->
      Doc ann
"Determined completion context:"
        forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Context
context
        forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"for cursor position:"
        forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Position
position
    LogCompletions Log
logs -> forall a ann. Pretty a => a -> 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 =
  (forall ideState. PluginId -> PluginDescriptor ideState
defaultCabalPluginDescriptor PluginId
plId)
    { pluginRules :: Rules ()
pluginRules = Recorder (WithPriority Log) -> Rules ()
cabalRules Recorder (WithPriority Log)
recorder
    , pluginHandlers :: PluginHandlers IdeState
pluginHandlers =
        forall a. Monoid a => [a] -> a
mconcat
          [ forall ideState (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'Method_TextDocumentCodeAction
LSP.SMethod_TextDocumentCodeAction PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
licenseSuggestCodeAction
          , forall ideState (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'Method_TextDocumentCompletion
LSP.SMethod_TextDocumentCompletion forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> PluginMethodHandler IdeState 'Method_TextDocumentCompletion
completion Recorder (WithPriority Log)
recorder
          ]
    , pluginNotificationHandlers :: PluginNotificationHandlers IdeState
pluginNotificationHandlers =
        forall a. Monoid a => [a] -> a
mconcat
          [ forall (m :: Method 'ClientToServer 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'Method_TextDocumentDidOpen
LSP.SMethod_TextDocumentDidOpen forall a b. (a -> b) -> a -> b
$
              \IdeState
ide VFS
vfs PluginId
_ (DidOpenTextDocumentParams TextDocumentItem{Uri
$sel:_uri:TextDocumentItem :: TextDocumentItem -> Uri
_uri :: Uri
_uri, Int32
$sel:_version:TextDocumentItem :: TextDocumentItem -> Int32
_version :: Int32
_version}) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
                  Priority -> Log -> IO ()
log' Priority
Debug forall a b. (a -> b) -> a -> b
$ Uri -> Log
LogDocOpened Uri
_uri
                  Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file Modified{firstOpen :: Bool
firstOpen = Bool
True}
                  ShakeExtras -> VFS -> NormalizedFilePath -> [Char] -> IO ()
restartCabalShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
ide) VFS
vfs NormalizedFilePath
file [Char]
"(opened)"
          , forall (m :: Method 'ClientToServer 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'Method_TextDocumentDidChange
LSP.SMethod_TextDocumentDidChange forall a b. (a -> b) -> a -> b
$
              \IdeState
ide VFS
vfs PluginId
_ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{Uri
$sel:_uri:VersionedTextDocumentIdentifier :: VersionedTextDocumentIdentifier -> Uri
_uri :: Uri
_uri} [TextDocumentContentChangeEvent]
_) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
                  Priority -> Log -> IO ()
log' Priority
Debug forall a b. (a -> b) -> a -> b
$ Uri -> Log
LogDocModified Uri
_uri
                  Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file Modified{firstOpen :: Bool
firstOpen = Bool
False}
                  ShakeExtras -> VFS -> NormalizedFilePath -> [Char] -> IO ()
restartCabalShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
ide) VFS
vfs NormalizedFilePath
file [Char]
"(changed)"
          , forall (m :: Method 'ClientToServer 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'Method_TextDocumentDidSave
LSP.SMethod_TextDocumentDidSave forall a b. (a -> b) -> a -> b
$
              \IdeState
ide VFS
vfs PluginId
_ (DidSaveTextDocumentParams TextDocumentIdentifier{Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri} Maybe Text
_) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
                  Priority -> Log -> IO ()
log' Priority
Debug forall a b. (a -> b) -> a -> b
$ Uri -> Log
LogDocSaved Uri
_uri
                  Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file FileOfInterestStatus
OnDisk
                  ShakeExtras -> VFS -> NormalizedFilePath -> [Char] -> IO ()
restartCabalShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
ide) VFS
vfs NormalizedFilePath
file [Char]
"(saved)"
          , forall (m :: Method 'ClientToServer 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'Method_TextDocumentDidClose
LSP.SMethod_TextDocumentDidClose forall a b. (a -> b) -> a -> b
$
              \IdeState
ide VFS
vfs PluginId
_ (DidCloseTextDocumentParams TextDocumentIdentifier{Uri
_uri :: Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri}) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
                  Priority -> Log -> IO ()
log' Priority
Debug forall a b. (a -> b) -> a -> b
$ Uri -> Log
LogDocClosed Uri
_uri
                  Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> IO ()
deleteFileOfInterest Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file
                  ShakeExtras -> VFS -> NormalizedFilePath -> [Char] -> IO ()
restartCabalShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
ide) VFS
vfs NormalizedFilePath
file [Char]
"(closed)"
          ]
    }
 where
  log' :: Priority -> Log -> IO ()
log' = forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder

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

{- | Helper function to restart the shake session, specifically for modifying .cabal files.
No special logic, just group up a bunch of functions you need for the base
Notification Handlers.

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

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

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

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

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

{- | This is the kick function for the cabal plugin.
We run this action, whenever we shake session us run/restarted, which triggers
actions to produce diagnostics for cabal files.

It is paramount that this kick-function can be run quickly, since it is a blocking
function invocation.
-}
kick :: Action ()
kick :: Action ()
kick = do
  [NormalizedFilePath]
files <- forall k v. HashMap k v -> [k]
HashMap.keys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action (HashMap NormalizedFilePath FileOfInterestStatus)
getCabalFilesOfInterestUntracked
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses ParseCabal
Types.ParseCabal [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}) =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ [Diagnostic]
diags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> a |? b
InR forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uri -> Diagnostic -> [CodeAction]
LicenseSuggest.licenseErrorAction Uri
uri)

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

{- | Cabal files that are currently open in the lsp-client.
Specific actions happen when these files are saved, closed or modified,
such as generating diagnostics, re-parsing, etc...

We need to store the open files to parse them again if we restart the shake session.
Restarting of the shake session happens whenever these files are modified.
-}
newtype OfInterestCabalVar = OfInterestCabalVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))

instance Shake.IsIdeGlobal OfInterestCabalVar

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

type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult

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

{- | The rule that initialises the files of interest state.

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

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

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

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

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