DRAFT: Cabal project plugin

haskell-language-server.cabal

@@ -317,6 +317,77 @@ test-suite hls-cabal-plugin-tests
     , text
     , hls-plugin-api
 
+-----------------------------
+-- cabal project plugin
+-----------------------------
+
+flag cabalProject
+  description: Enable cabalProject plugin
+  default:     True
+  manual:      True
+
+common cabalProject
+  if flag(cabalProject)
+    build-depends: haskell-language-server:hls-cabal-project-plugin
+    cpp-options: -Dhls_cabal_project
+
+library hls-cabal-project-plugin
+  import:           defaults, pedantic, warnings
+  if !flag(cabal)
+    buildable: False
+  exposed-modules:
+    Ide.Plugin.CabalProject
+
+
+  build-depends:
+    , bytestring
+    , Cabal-syntax          >= 3.7
+    , containers
+    , deepseq
+    , directory
+    , filepath
+    , extra                 >=1.7.4
+    , ghcide                == 2.11.0.0
+    , hashable
+    , hls-plugin-api        == 2.11.0.0
+    , hls-graph             == 2.11.0.0
+    , lens
+    , lsp                   ^>=2.7
+    , lsp-types             ^>=2.3
+    , regex-tdfa            ^>=1.3.1
+    , text
+    , text-rope
+    , transformers
+    , unordered-containers  >=0.2.10.0
+    , containers
+    , process
+    , aeson
+    , Cabal
+    , pretty
+
+  hs-source-dirs:   plugins/hls-cabal-project-plugin/src
+
+test-suite hls-cabal-project-plugin-tests
+  import:           defaults, pedantic, test-defaults, warnings
+  if !flag(cabalProject)
+    buildable: False
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   plugins/hls-cabal-project-plugin/test
+  main-is:          Main.hs
+  other-modules:
+  build-depends:
+    , bytestring
+    , Cabal-syntax          >= 3.7
+    , extra
+    , filepath
+    , ghcide
+    , haskell-language-server:hls-cabal-project-plugin
+    , hls-test-utils    == 2.11.0.0
+    , lens
+    , lsp-types
+    , text
+    , hls-plugin-api
+
 -----------------------------
 -- class plugin
 -----------------------------
@@ -1830,6 +1901,7 @@ library
                   , pedantic
                   -- plugins
                   , cabal
+                  , cabalProject
                   , callHierarchy
                   , cabalfmt
                   , cabalgild

hls-plugin-api/src/Ide/Types.hs

@@ -14,7 +14,7 @@
 {-# LANGUAGE UndecidableInstances  #-}
 {-# LANGUAGE ViewPatterns          #-}
 module Ide.Types
-( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor
+( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor, defaultCabalProjectPluginDescriptor
 , defaultPluginPriority
 , describePlugin
 , IdeCommand(..)
@@ -1077,6 +1077,21 @@ defaultCabalPluginDescriptor plId desc =
     Nothing
     [".cabal"]
 
+defaultCabalProjectPluginDescriptor :: PluginId -> T.Text -> PluginDescriptor ideState
+defaultCabalProjectPluginDescriptor plId desc =
+  PluginDescriptor
+    plId
+    desc
+    defaultPluginPriority
+    mempty
+    mempty
+    mempty
+    defaultConfigDescriptor
+    mempty
+    mempty
+    Nothing
+    [".project"]
+
 newtype CommandId = CommandId T.Text
   deriving (Show, Read, Eq, Ord)
 instance IsString CommandId where

plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs

@@ -0,0 +1,218 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TypeFamilies          #-}
+
+module Ide.Plugin.CabalProject 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                     (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                                     as List
+import qualified Data.List.NonEmpty                            as NE
+import qualified Data.Maybe                                    as Maybe
+import           Data.Proxy
+import qualified Data.Text                                     ()
+import qualified Data.Text                                     as T
+import qualified Data.Text.Encoding                            as Encoding
+import           Data.Text.Utf16.Rope.Mixed                    as Rope
+import           Development.IDE                               as D
+import           Development.IDE.Core.FileStore                (getVersionedTextDoc)
+import           Development.IDE.Core.PluginUtils
+import           Development.IDE.Core.Shake                    (restartShakeSession)
+import qualified Development.IDE.Core.Shake                    as Shake
+import           Development.IDE.Graph                         (Key,
+                                                                alwaysRerun)
+import           Development.IDE.LSP.HoverDefinition           (foundHover)
+import qualified Development.IDE.Plugin.Completions.Logic      as Ghcide
+import           Development.IDE.Types.Shake                   (toKey)
+import qualified Distribution.CabalSpecVersion                 as Cabal
+import qualified Distribution.Fields                           as Syntax
+import           Distribution.Package                          (Dependency)
+import           Distribution.PackageDescription               (allBuildDepends,
+                                                                depPkgName,
+                                                                unPackageName)
+import           Distribution.PackageDescription.Configuration (flattenPackageDescription)
+import           Distribution.Parsec.Error
+import qualified Distribution.Parsec.Position                  as Syntax
+import           GHC.Generics
+import           Ide.Plugin.Error
+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
+import           Text.Regex.TDFA
+
+data Log
+  = LogModificationTime NormalizedFilePath FileVersion
+  | LogShake Shake.Log
+  | LogDocOpened Uri
+  | LogDocModified Uri
+  | LogDocSaved Uri
+  | LogDocClosed Uri
+  | LogFOI (HashMap NormalizedFilePath FileOfInterestStatus)
+  deriving (Show)
+
+instance Pretty Log where
+  pretty = \case
+    LogShake log' -> pretty log'
+    LogModificationTime nfp modTime ->
+      "Modified:" <+> pretty (fromNormalizedFilePath nfp) <+> pretty (show modTime)
+    LogDocOpened uri ->
+      "Opened text document:" <+> pretty (getUri uri)
+    LogDocModified uri ->
+      "Modified text document:" <+> pretty (getUri uri)
+    LogDocSaved uri ->
+      "Saved text document:" <+> pretty (getUri uri)
+    LogDocClosed uri ->
+      "Closed text document:" <+> pretty (getUri uri)
+    LogFOI files ->
+      "Set files of interest to:" <+> viaShow files
+
+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
+descriptor recorder plId =
+  (defaultCabalProjectPluginDescriptor plId "Provides a variety of IDE features in cabal files")
+    { pluginRules = cabalRules recorder plId
+    , pluginHandlers =
+        mconcat
+          []
+    , pluginNotificationHandlers =
+        mconcat
+          [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $
+              \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri, _version}) -> liftIO $ do
+                whenUriFile _uri $ \file -> do
+                  log' Debug $ LogDocOpened _uri
+                  restartCabalShakeSession (shakeExtras ide) vfs file "(opened)" $
+                    addFileOfInterest recorder ide file Modified{firstOpen = True}
+          , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $
+              \ide vfs _ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> liftIO $ do
+                whenUriFile _uri $ \file -> do
+                  log' Debug $ LogDocModified _uri
+                  restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" $
+                    addFileOfInterest recorder ide file Modified{firstOpen = False}
+          , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $
+              \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do
+                whenUriFile _uri $ \file -> do
+                  log' Debug $ LogDocSaved _uri
+                  restartCabalShakeSession (shakeExtras ide) vfs file "(saved)" $
+                    addFileOfInterest recorder ide file OnDisk
+          , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $
+              \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do
+                whenUriFile _uri $ \file -> do
+                  log' Debug $ LogDocClosed _uri
+                  restartCabalShakeSession (shakeExtras ide) vfs file "(closed)" $
+                    deleteFileOfInterest recorder ide file
+          ]
+    , pluginConfigDescriptor = defaultConfigDescriptor
+      { configHasDiagnostics = True
+      }
+    }
+ where
+  log' = logWith recorder
+
+  whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
+  whenUriFile uri act = whenJust (uriToFilePath uri) $ act . toNormalizedFilePath'
+
+cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules ()
+cabalRules recorder _ = do
+    ofInterestRules recorder
+
+{- | 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 file actionMsg actionBetweenSession = do
+  restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do
+    keys <- actionBetweenSession
+    return (toKey GetModificationTime file:keys)
+
+-- ----------------------------------------------------------------
+-- 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 (Eq, Show, Generic)
+instance Hashable IsCabalFileOfInterest
+instance NFData IsCabalFileOfInterest
+
+type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult
+
+data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus
+  deriving (Eq, Show, 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 = do
+  Shake.addIdeGlobal . OfInterestCabalVar =<< liftIO (newVar HashMap.empty)
+  Shake.defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsCabalFileOfInterest f -> do
+    alwaysRerun
+    filesOfInterest <- getCabalFilesOfInterestUntracked
+    let foi = maybe NotCabalFOI IsCabalFOI $ f `HashMap.lookup` filesOfInterest
+        fp = summarize foi
+        res = (Just fp, Just foi)
+    return res
+ where
+  summarize NotCabalFOI                   = BS.singleton 0
+  summarize (IsCabalFOI OnDisk)           = BS.singleton 1
+  summarize (IsCabalFOI (Modified False)) = BS.singleton 2
+  summarize (IsCabalFOI (Modified True))  = BS.singleton 3
+
+getCabalFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus)
+getCabalFilesOfInterestUntracked = do
+  OfInterestCabalVar var <- Shake.getIdeGlobalAction
+  liftIO $ readVar var
+
+addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key]
+addFileOfInterest recorder state f v = do
+  OfInterestCabalVar var <- Shake.getIdeGlobalState state
+  (prev, files) <- modifyVar var $ \dict -> do
+    let (prev, new) = HashMap.alterF (,Just v) f dict
+    pure (new, (prev, new))
+  if prev /= Just v
+    then do
+        log' Debug $ LogFOI files
+        return [toKey IsCabalFileOfInterest f]
+    else return []
+ where
+  log' = logWith recorder
+
+deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO [Key]
+deleteFileOfInterest recorder state f = do
+  OfInterestCabalVar var <- Shake.getIdeGlobalState state
+  files <- modifyVar' var $ HashMap.delete f
+  log' Debug $ LogFOI files
+  return [toKey IsFileOfInterest f]
+ where
+  log' = logWith recorder

plugins/hls-cabal-project-plugin/test/Main.hs

@@ -0,0 +1,3 @@
+module Main where
+
+main = undefined

src/HlsPlugins.hs

@@ -23,6 +23,9 @@ import qualified Ide.Plugin.CallHierarchy          as CallHierarchy
 #if hls_cabal
 import qualified Ide.Plugin.Cabal                  as Cabal
 #endif
+#if hls_cabal_project
+import qualified Ide.Plugin.CabalProject           as CabalProject
+#endif
 #if hls_class
 import qualified Ide.Plugin.Class                  as Class
 #endif
@@ -154,6 +157,9 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins
       let pId = "cabal" in Cabal.descriptor (pluginRecorder pId) pId :
       let caId = "cabalHaskellIntegration" in Cabal.haskellInteractionDescriptor (pluginRecorder caId) caId :
 #endif
+#if hls_cabal_project
+      let pId = "cabalProject" in CabalProject.descriptor (pluginRecorder pId) pId :
+#endif
 #if hls_pragmas
       Pragmas.suggestPragmaDescriptor  "pragmas-suggest" :
       Pragmas.completionDescriptor  "pragmas-completion" :

test.cpp

@@ -0,0 +1,3 @@
+#include <iostream>
+int main() { std::cout << "OK
+"; return 0; }