diff --git a/ghcide/session-loader/Development/IDE/Session/Implicit.hs b/ghcide/session-loader/Development/IDE/Session/Implicit.hs index e8e804e3c15..5726f9698ba 100644 --- a/ghcide/session-loader/Development/IDE/Session/Implicit.hs +++ b/ghcide/session-loader/Development/IDE/Session/Implicit.hs @@ -1,6 +1,6 @@ module Development.IDE.Session.Implicit ( loadImplicitCradle - ) where + , findFileUpwardsF) where import Control.Applicative ((<|>)) @@ -144,6 +144,24 @@ findFileUpwards p dir = do _ : _ -> return dir where dir' = takeDirectory dir +-- | Searches upwards for the first file to match +-- the predicate. +findFileUpwardsF :: (FilePath -> Bool) -> FilePath -> MaybeT IO [FilePath] +findFileUpwardsF p dir = do + cnts <- + liftIO + $ handleJust + -- Catch permission errors + (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing) + pure + (findFile p dir) + + case cnts of + [] | dir' == dir -> fail "No cabal files" + | otherwise -> findFileUpwardsF p dir' + files -> pure $ fmap (dir ) files + where dir' = takeDirectory dir + -- | Sees if any file in the directory matches the predicate findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath] findFile p dir = do diff --git a/plugins/hls-stan-plugin/hls-stan-plugin.cabal b/plugins/hls-stan-plugin/hls-stan-plugin.cabal index 4d440767f55..aa4f8d610fa 100644 --- a/plugins/hls-stan-plugin/hls-stan-plugin.cabal +++ b/plugins/hls-stan-plugin/hls-stan-plugin.cabal @@ -47,6 +47,9 @@ library , transformers , unordered-containers , stan >= 0.1.1.0 + , trial + , filepath + , directory default-language: Haskell2010 default-extensions: diff --git a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs index f45a604a678..782f7d880a6 100644 --- a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs +++ b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs @@ -1,47 +1,52 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} module Ide.Plugin.Stan (descriptor, Log) where -import Compat.HieTypes (HieASTs, HieFile) -import Control.DeepSeq (NFData) -import Control.Monad (void) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) +import Compat.HieTypes (HieASTs, HieFile (..)) +import Control.DeepSeq (NFData) +import Control.Monad (void, when) +import Control.Monad.IO.Class (liftIO) +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 qualified Data.Map as Map -import Data.Maybe (fromJust, mapMaybe) -import qualified Data.Text as T +import Data.Foldable (toList) +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as Map +import Data.Maybe (fromJust, mapMaybe, + maybeToList) +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), - RealSrcSpan (..), mkHieFile', - mkRealSrcLoc, mkRealSrcSpan, - runHsc, srcSpanEndCol, - srcSpanEndLine, - srcSpanStartCol, - srcSpanStartLine, tcg_exports) -import Development.IDE.GHC.Error (realSrcSpanToRange) -import GHC.Generics (Generic) +import Development.IDE.Core.Rules (getHieFile) +import Development.IDE.Core.RuleTypes (HieAstResult (..)) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Session.Implicit (findFileUpwardsF) +import GHC.Generics (Generic) import Ide.Plugin.Config -import Ide.Types (PluginDescriptor (..), - PluginId, configHasDiagnostics, - defaultConfigDescriptor, - defaultPluginDescriptor, - pluginEnabledConfig) -import qualified Language.LSP.Protocol.Types as LSP -import Stan.Analysis (Analysis (..), runAnalysis) -import Stan.Category (Category (..)) -import Stan.Core.Id (Id (..)) -import Stan.Inspection (Inspection (..)) -import Stan.Inspection.All (inspectionsIds, inspectionsMap) -import Stan.Observation (Observation (..)) +import Ide.Types (PluginDescriptor (..), + PluginId, + configHasDiagnostics, + defaultConfigDescriptor, + defaultPluginDescriptor, + pluginEnabledConfig) +import qualified Language.LSP.Protocol.Types as LSP +import Stan (createCabalExtensionsMap) +import Stan.Analysis (Analysis (..), runAnalysis) +import Stan.Category (Category (..)) +import Stan.Config (ConfigP (configIgnored), + applyConfig, defaultConfig, + finaliseConfig) +import Stan.Core.Id (Id (..)) +import Stan.EnvVars (EnvVars (..), getEnvVars) +import Stan.Inspection (Inspection (..)) +import Stan.Inspection.All (inspectionsIds, + inspectionsMap) +import Stan.Observation (Observation (..)) +import Stan.Toml (getTomlConfig) +import System.Directory (makeRelativeToCurrentDirectory) +import System.FilePath (takeExtension) +import Trial (Fatality, pattern FiascoL, + pattern ResultL, + trialToMaybe) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId desc) @@ -53,11 +58,21 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) where desc = "Provides stan diagnostics. Built with stan-" <> VERSION_stan -newtype Log = LogShake Shake.Log deriving (Show) +data Log = LogShake !Shake.Log + | LogDebug !T.Text + | LogWarnConf ![(Fatality, T.Text)] + | LogWarnCabalNotFound + deriving (Show) instance Pretty Log where pretty = \case LogShake log -> pretty log + LogDebug msg -> pretty msg + LogWarnConf errs -> + "Fiasco encountered when trying to load stan configuration. Using default inspections:" + <> line <> (pretty $ show errs) + LogWarnCabalNotFound -> + "Cabal file not found. Using default stan config for extensions." data GetStanDiagnostics = GetStanDiagnostics deriving (Eq, Show, Generic) @@ -72,15 +87,66 @@ rules :: Recorder (WithPriority Log) -> PluginId -> Rules () rules recorder plId = do define (cmapWithPrio LogShake recorder) $ \GetStanDiagnostics file -> do - config <- getPluginConfigAction plId - if pluginEnabledConfig plcDiagnosticsOn config then do + plugConfig <- getPluginConfigAction plId + if pluginEnabledConfig plcDiagnosticsOn plugConfig 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 currentHSfromHIEAbs = hie_hs_file hie + currentHSfromHIERel <- liftIO $ makeRelativeToCurrentDirectory currentHSfromHIEAbs + -- This codes follows what 'runStan' does, from the module 'Stan' + + -- There aren't any cli args. isLoud=False=Silent output + let isLoud = False -- Should this be enabled when debugging? Enables default stan cli output + let stanArgsConfigFile = Nothing -- There aren't any cli args + + EnvVars{envVarsUseDefaultConfigFile} <- liftIO getEnvVars + logWith recorder Debug (LogDebug $ + "envVarsUseDefaultConfigFile: " <> (T.pack $ show envVarsUseDefaultConfigFile)) + + let defConfTrial = envVarsUseDefaultConfigFile -- There aren't any cli args: <> stanArgsUseDefaultConfigFile + let useDefConfig = maybe True snd (trialToMaybe defConfTrial) + + tomlConfig <- liftIO $ getTomlConfig isLoud useDefConfig stanArgsConfigFile + let configTrial = finaliseConfig $ defaultConfig <> tomlConfig -- There aren't any cli args: <> stanArgsConfig + logWith recorder Debug (LogDebug $ "Final stan config result\n" <> ( T.pack $ show configTrial)) + + (cabalExtensionsMap, checksMap, confIgnored) <- case configTrial of + FiascoL es -> do + logWith recorder Warning (LogWarnConf es) + pure (Map.empty, + HM.fromList [(LSP.fromNormalizedFilePath file, inspectionsIds)], + []) + ResultL warnings stanConfig -> do + -- I'm not sure this is the best way to obtain the .cabal + -- for this file but it'll have to do. Anyways, if it is not + -- found it's not a big issue. That was the default previously. + maybeCabalFileDir <- let maybeCabalFileDir = findFileUpwardsF + (\fp -> takeExtension fp == ".cabal") + currentHSfromHIEAbs + in liftIO (mconcat . maybeToList <$> runMaybeT maybeCabalFileDir) + cabalExtensionsMap <- liftIO $ case maybeCabalFileDir of + [] -> do + logWith recorder Warning LogWarnCabalNotFound + pure Map.empty + cabalFileDirs -> do + logWith recorder Debug (LogDebug $ + "absolute cabalFilePath: " <> (T.pack $ show cabalFileDirs)) + createCabalExtensionsMap isLoud maybeCabalFileDir [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. I'm not sure why that's a problem here and + -- not in stan itself. + let checksMap = HM.mapKeys (const currentHSfromHIEAbs) $ applyConfig [currentHSfromHIERel] stanConfig + + logWith recorder Debug (LogDebug $ + "checksMap" <> (T.pack $ show checksMap)) + pure (cabalExtensionsMap, checksMap, configIgnored stanConfig) + + let analysis = runAnalysis cabalExtensionsMap checksMap confIgnored [hie] return (analysisToDiagnostics file analysis, Just ()) else return ([], Nothing)