diff --git a/hls-stan-plugin.cabal b/hls-stan-plugin.cabal --- a/hls-stan-plugin.cabal +++ b/hls-stan-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-stan-plugin -version: 2.5.0.0 +version: 2.6.0.0 synopsis: Stan integration plugin with Haskell Language Server description: Please see the README on GitHub at @@ -46,7 +46,9 @@ , text , transformers , unordered-containers - , stan + , stan >= 0.1.2.0 + , trial + , directory default-language: Haskell2010 default-extensions: @@ -75,7 +77,7 @@ , filepath , hls-stan-plugin , hls-plugin-api - , hls-test-utils == 2.5.0.0 + , hls-test-utils == 2.6.0.0 , lens , lsp-types , text diff --git a/src/Ide/Plugin/Stan.hs b/src/Ide/Plugin/Stan.hs --- a/src/Ide/Plugin/Stan.hs +++ b/src/Ide/Plugin/Stan.hs @@ -1,25 +1,30 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} module Ide.Plugin.Stan (descriptor, Log) where -import Compat.HieTypes (HieASTs, HieFile) +import Compat.HieTypes (HieASTs, HieFile (..)) import Control.DeepSeq (NFData) -import Control.Monad (void) +import Control.Monad (void, when) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) import Data.Default import Data.Foldable (toList) import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HM +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS import qualified Data.Map as Map -import Data.Maybe (fromJust, mapMaybe) +import Data.Maybe (fromJust, mapMaybe, + maybeToList) +import Data.String (IsString (fromString)) import qualified Data.Text as T import Development.IDE -import Development.IDE (Diagnostic (_codeDescription)) import Development.IDE.Core.Rules (getHieFile, getSourceFileSource) import Development.IDE.Core.RuleTypes (HieAstResult (..)) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat (HieASTs (HieASTs), + HieFile (hie_hs_file), RealSrcSpan (..), mkHieFile', mkRealSrcLoc, mkRealSrcSpan, runHsc, srcSpanEndCol, @@ -28,34 +33,91 @@ srcSpanStartLine, tcg_exports) import Development.IDE.GHC.Error (realSrcSpanToRange) import GHC.Generics (Generic) -import Ide.Plugin.Config +import Ide.Plugin.Config (PluginConfig (..)) import Ide.Types (PluginDescriptor (..), PluginId, configHasDiagnostics, + configInitialGenericConfig, defaultConfigDescriptor, - defaultPluginDescriptor, - pluginEnabledConfig) + defaultPluginDescriptor) import qualified Language.LSP.Protocol.Types as LSP +import Stan (createCabalExtensionsMap, + getStanConfig) import Stan.Analysis (Analysis (..), runAnalysis) import Stan.Category (Category (..)) +import Stan.Cli (StanArgs (..)) +import Stan.Config (Config, ConfigP (..), + applyConfig, defaultConfig) +import Stan.Config.Pretty (ConfigAction, configToTriples, + prettyConfigAction, + prettyConfigCli) import Stan.Core.Id (Id (..)) +import Stan.EnvVars (EnvVars (..), envVarsToText) import Stan.Inspection (Inspection (..)) import Stan.Inspection.All (inspectionsIds, inspectionsMap) import Stan.Observation (Observation (..)) - +import Stan.Report.Settings (OutputSettings (..), + ToggleSolution (..), + Verbosity (..)) +import Stan.Toml (usedTomlFiles) +import System.Directory (makeRelativeToCurrentDirectory) +import Trial (Fatality, Trial (..), fiasco, + pattern FiascoL, + pattern ResultL, prettyTrial, + prettyTrialWith) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) +descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginRules = rules recorder plId - , pluginConfigDescriptor = defaultConfigDescriptor + , pluginConfigDescriptor = defConfigDescriptor { configHasDiagnostics = True + -- We disable this plugin by default because users have been complaining about + -- the diagnostics, see https://github.com/haskell/haskell-language-server/issues/3916 + , configInitialGenericConfig = (configInitialGenericConfig defConfigDescriptor) + { plcGlobalOn = False + } } } + where + defConfigDescriptor = defaultConfigDescriptor + desc = "Provides stan diagnostics. Built with stan-" <> VERSION_stan -newtype Log = LogShake Shake.Log deriving (Show) +data Log = LogShake !Shake.Log + | LogWarnConf ![(Fatality, T.Text)] + | LogDebugStanConfigResult ![FilePath] !(Trial T.Text Config) + | LogDebugStanEnvVars !EnvVars +-- We use this function to remove the terminal escape sequences emmited by Trial pretty printing functions. +-- See https://github.com/kowainik/trial/pull/73#issuecomment-1868233235 +stripModifiers :: T.Text -> T.Text +stripModifiers = go "" + where + go acc txt = + case T.findIndex (== '\x1B') txt of + Nothing -> acc <> txt + Just index -> let (beforeEsc, afterEsc) = T.splitAt index txt + in go (acc <> beforeEsc) (consumeEscapeSequence afterEsc) + consumeEscapeSequence :: T.Text -> T.Text + consumeEscapeSequence txt = + case T.findIndex (== 'm') txt of + Nothing -> txt + Just index -> T.drop (index + 1) txt + +renderId :: Id a -> T.Text +renderId (Id t) = "Id = " <> t + instance Pretty Log where pretty = \case LogShake log -> pretty log + LogWarnConf errs -> "Fiasco encountered when trying to load stan configuration. Using default inspections:" + <> line <> (pretty $ show errs) + LogDebugStanConfigResult fps t -> "Config result using: " + <> pretty fps <> line <> pretty (stripModifiers $ prettyTrialWith (T.unpack . prettyConfigCli) t) + LogDebugStanEnvVars envVars -> "EnvVars " <> + case envVars of + EnvVars trial@(FiascoL _) -> pretty (stripModifiers $ prettyTrial trial) + -- if the envVars are not set, 'envVarsToText returns an empty string' + _ -> "found: " <> (pretty $ envVarsToText envVars) + data GetStanDiagnostics = GetStanDiagnostics deriving (Eq, Show, Generic) @@ -70,14 +132,56 @@ define (cmapWithPrio LogShake recorder) $ \GetStanDiagnostics file -> do config <- getPluginConfigAction plId - if pluginEnabledConfig plcDiagnosticsOn config then do + if plcGlobalOn config && plcDiagnosticsOn config then do maybeHie <- getHieFile file case maybeHie of Nothing -> return ([], Nothing) Just hie -> do - let enabledInspections = HM.fromList [(LSP.fromNormalizedFilePath file, inspectionsIds)] - -- This should use Cabal config for extensions and Stan config for inspection preferences is the future - let analysis = runAnalysis Map.empty enabledInspections [] [hie] + let isLoud = False -- in Stan: notJson = not isLoud + let stanArgs = + StanArgs + { stanArgsHiedir = "" -- :: !FilePath -- ^ Directory with HIE files + , stanArgsCabalFilePath = [] -- :: ![FilePath] -- ^ Path to @.cabal@ files. + , stanArgsOutputSettings = OutputSettings NonVerbose ShowSolution -- :: !OutputSettings -- ^ Settings for output terminal report + -- doesnt matter, because it is silenced by isLoud + , stanArgsReport = Nothing -- :: !(Maybe ReportArgs) -- ^ @HTML@ report settings + , stanArgsUseDefaultConfigFile = fiasco "" -- :: !(TaggedTrial Text Bool) -- ^ Use default @.stan.toml@ file + , stanArgsConfigFile = Nothing -- :: !(Maybe FilePath) -- ^ Path to a custom configurations file. + , stanArgsConfig = ConfigP + { configChecks = fiasco "'hls-stan-plugin' doesn't receive CLI options for: checks" + , configRemoved = fiasco "'hls-stan-plugin' doesn't receive CLI options for: remove" + , configIgnored = fiasco "'hls-stan-plugin' doesn't receive CLI options for: ignore" + } + -- if they are not fiascos, .stan.toml's aren't taken into account + ,stanArgsJsonOut = not isLoud -- :: !Bool -- ^ Output the machine-readable output in JSON format instead. + } + + (configTrial, useDefConfig, env) <- liftIO $ getStanConfig stanArgs isLoud + seTomlFiles <- liftIO $ usedTomlFiles useDefConfig (stanArgsConfigFile stanArgs) + logWith recorder Debug (LogDebugStanConfigResult seTomlFiles configTrial) + + -- If envVar is set to 'False', stan will ignore all local and global .stan.toml files + logWith recorder Debug (LogDebugStanEnvVars env) + seTomlFiles <- liftIO $ usedTomlFiles useDefConfig (stanArgsConfigFile stanArgs) + + (cabalExtensionsMap, checksMap, confIgnored) <- case configTrial of + FiascoL es -> do + logWith recorder Development.IDE.Warning (LogWarnConf es) + pure (Map.empty, + HM.fromList [(LSP.fromNormalizedFilePath file, inspectionsIds)], + []) + ResultL warnings stanConfig -> do + let currentHSAbs = fromNormalizedFilePath file -- hie_hs_file hie + currentHSRel <- liftIO $ makeRelativeToCurrentDirectory currentHSAbs + cabalExtensionsMap <- liftIO $ createCabalExtensionsMap isLoud (stanArgsCabalFilePath stanArgs) [hie] + + -- Files (keys) in checksMap need to have an absolute path for the analysis, but applyConfig needs to receive relative + -- filepaths to apply the config, because the toml config has relative paths. Stan itself seems to work only in terms of relative paths. + let checksMap = HM.mapKeys (const currentHSAbs) $ applyConfig [currentHSRel] stanConfig + + let analysis = runAnalysis cabalExtensionsMap checksMap (configIgnored stanConfig) [hie] + pure (cabalExtensionsMap, checksMap, configIgnored stanConfig) + let analysis = runAnalysis cabalExtensionsMap checksMap confIgnored [hie] return (analysisToDiagnostics file analysis, Just ()) else return ([], Nothing) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -10,6 +10,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Ide.Plugin.Stan as Stan +import Ide.Types import qualified Language.LSP.Protocol.Lens as L import System.FilePath import Test.Hls @@ -33,13 +34,32 @@ assertBool "" $ T.isPrefixOf expectedPrefix (reduceDiag ^. L.message) reduceDiag ^. L.source @?= Just "stan" return () + , testCase "ignores diagnostics from .stan.toml" $ + runStanSession "" $ do + doc <- openDoc "dir/configTest.hs" "haskell" + diags <- waitForDiagnosticsFromSource doc "stan" + liftIO $ length diags @?= 0 + return () ] testDir :: FilePath testDir = "test/testdata" stanPlugin :: PluginTestDescriptor Stan.Log -stanPlugin = mkPluginTestDescriptor Stan.descriptor "stan" +stanPlugin = mkPluginTestDescriptor enabledStanDescriptor "stan" + where + -- We have to explicitly enable the plugin as it is disabled by default as + -- per request: https://github.com/haskell/haskell-language-server/issues/3916 + -- + enabledStanDescriptor recorder plId = + let stanPluginDescriptor = Stan.descriptor recorder plId + in stanPluginDescriptor + { pluginConfigDescriptor = (pluginConfigDescriptor stanPluginDescriptor) + { configInitialGenericConfig = (configInitialGenericConfig (pluginConfigDescriptor stanPluginDescriptor)) + { plcGlobalOn = True + } + } + } runStanSession :: FilePath -> Session a -> IO a runStanSession subdir =