Skip to content

Commit 81c84cf

Browse files
0rphee0rphee
committed
Use stan config files for stan plugin (haskell#3904)
1 parent 2b49d9d commit 81c84cf

File tree

3 files changed

+133
-46
lines changed

3 files changed

+133
-46
lines changed

‎ghcide/session-loader/Development/IDE/Session/Implicit.hs

Lines changed: 19 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
module Development.IDE.Session.Implicit
22
( loadImplicitCradle
3-
) where
3+
, findFileUpwardsF) where
44

55

66
import Control.Applicative ((<|>))
@@ -144,6 +144,24 @@ findFileUpwards p dir = do
144144
_ : _ -> return dir
145145
where dir' = takeDirectory dir
146146

147+
-- | Searches upwards for the first file to match
148+
-- the predicate.
149+
findFileUpwardsF :: (FilePath -> Bool) -> FilePath -> MaybeT IO [FilePath]
150+
findFileUpwardsF p dir = do
151+
cnts <-
152+
liftIO
153+
$ handleJust
154+
-- Catch permission errors
155+
(\(e :: IOError) -> if isPermissionError e then Just [] else Nothing)
156+
pure
157+
(findFile p dir)
158+
159+
case cnts of
160+
[] | dir' == dir -> fail "No cabal files"
161+
| otherwise -> findFileUpwardsF p dir'
162+
files -> pure $ fmap (dir </>) files
163+
where dir' = takeDirectory dir
164+
147165
-- | Sees if any file in the directory matches the predicate
148166
findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
149167
findFile p dir = do

‎plugins/hls-stan-plugin/hls-stan-plugin.cabal

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -47,6 +47,9 @@ library
4747
, transformers
4848
, unordered-containers
4949
, stan >= 0.1.1.0
50+
, trial
51+
, filepath
52+
, directory
5053

5154
default-language: Haskell2010
5255
default-extensions:

‎plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs

Lines changed: 111 additions & 45 deletions
Original file line numberDiff line numberDiff line change
@@ -1,47 +1,52 @@
1-
{-# LANGUAGE CPP #-}
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE PatternSynonyms #-}
23
module Ide.Plugin.Stan (descriptor, Log) where
34

4-
import Compat.HieTypes (HieASTs, HieFile)
5-
import Control.DeepSeq (NFData)
6-
import Control.Monad (void)
7-
import Control.Monad.IO.Class (liftIO)
8-
import Control.Monad.Trans.Class (lift)
9-
import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)
5+
import Compat.HieTypes (HieASTs, HieFile (..))
6+
import Control.DeepSeq (NFData)
7+
import Control.Monad (void, when)
8+
import Control.Monad.IO.Class (liftIO)
9+
import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)
1010
import Data.Default
11-
import Data.Foldable (toList)
12-
import Data.Hashable (Hashable)
13-
import qualified Data.HashMap.Strict as HM
14-
import qualified Data.Map as Map
15-
import Data.Maybe (fromJust, mapMaybe)
16-
import qualified Data.Text as T
11+
import Data.Foldable (toList)
12+
import Data.Hashable (Hashable)
13+
import qualified Data.HashMap.Strict as HM
14+
import qualified Data.Map as Map
15+
import Data.Maybe (fromJust, mapMaybe,
16+
maybeToList)
17+
import qualified Data.Text as T
1718
import Development.IDE
18-
import Development.IDE (Diagnostic (_codeDescription))
19-
import Development.IDE.Core.Rules (getHieFile,
20-
getSourceFileSource)
21-
import Development.IDE.Core.RuleTypes (HieAstResult (..))
22-
import qualified Development.IDE.Core.Shake as Shake
23-
import Development.IDE.GHC.Compat (HieASTs (HieASTs),
24-
RealSrcSpan (..), mkHieFile',
25-
mkRealSrcLoc, mkRealSrcSpan,
26-
runHsc, srcSpanEndCol,
27-
srcSpanEndLine,
28-
srcSpanStartCol,
29-
srcSpanStartLine, tcg_exports)
30-
import Development.IDE.GHC.Error (realSrcSpanToRange)
31-
import GHC.Generics (Generic)
19+
import Development.IDE.Core.Rules (getHieFile)
20+
import Development.IDE.Core.RuleTypes (HieAstResult (..))
21+
import qualified Development.IDE.Core.Shake as Shake
22+
import Development.IDE.Session.Implicit (findFileUpwardsF)
23+
import GHC.Generics (Generic)
3224
import Ide.Plugin.Config
33-
import Ide.Types (PluginDescriptor (..),
34-
PluginId, configHasDiagnostics,
35-
defaultConfigDescriptor,
36-
defaultPluginDescriptor,
37-
pluginEnabledConfig)
38-
import qualified Language.LSP.Protocol.Types as LSP
39-
import Stan.Analysis (Analysis (..), runAnalysis)
40-
import Stan.Category (Category (..))
41-
import Stan.Core.Id (Id (..))
42-
import Stan.Inspection (Inspection (..))
43-
import Stan.Inspection.All (inspectionsIds, inspectionsMap)
44-
import Stan.Observation (Observation (..))
25+
import Ide.Types (PluginDescriptor (..),
26+
PluginId,
27+
configHasDiagnostics,
28+
defaultConfigDescriptor,
29+
defaultPluginDescriptor,
30+
pluginEnabledConfig)
31+
import qualified Language.LSP.Protocol.Types as LSP
32+
import Stan (createCabalExtensionsMap)
33+
import Stan.Analysis (Analysis (..), runAnalysis)
34+
import Stan.Category (Category (..))
35+
import Stan.Config (ConfigP (configIgnored),
36+
applyConfig, defaultConfig,
37+
finaliseConfig)
38+
import Stan.Core.Id (Id (..))
39+
import Stan.EnvVars (EnvVars (..), getEnvVars)
40+
import Stan.Inspection (Inspection (..))
41+
import Stan.Inspection.All (inspectionsIds,
42+
inspectionsMap)
43+
import Stan.Observation (Observation (..))
44+
import Stan.Toml (getTomlConfig)
45+
import System.Directory (makeRelativeToCurrentDirectory)
46+
import System.FilePath (takeExtension)
47+
import Trial (Fatality, pattern FiascoL,
48+
pattern ResultL,
49+
trialToMaybe)
4550

4651
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
4752
descriptor recorder plId = (defaultPluginDescriptor plId desc)
@@ -53,11 +58,21 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc)
5358
where
5459
desc = "Provides stan diagnostics. Built with stan-" <> VERSION_stan
5560

56-
newtype Log = LogShake Shake.Log deriving (Show)
61+
data Log = LogShake !Shake.Log
62+
| LogDebug !T.Text
63+
| LogWarnConf ![(Fatality, T.Text)]
64+
| LogWarnCabalNotFound
65+
deriving (Show)
5766

5867
instance Pretty Log where
5968
pretty = \case
6069
LogShake log -> pretty log
70+
LogDebug msg -> pretty msg
71+
LogWarnConf errs ->
72+
"Fiasco encountered when trying to load stan configuration. Using default inspections:"
73+
<> line <> (pretty $ show errs)
74+
LogWarnCabalNotFound ->
75+
"Cabal file not found. Using default stan config for extensions."
6176

6277
data GetStanDiagnostics = GetStanDiagnostics
6378
deriving (Eq, Show, Generic)
@@ -72,15 +87,66 @@ rules :: Recorder (WithPriority Log) -> PluginId -> Rules ()
7287
rules recorder plId = do
7388
define (cmapWithPrio LogShake recorder) $
7489
\GetStanDiagnostics file -> do
75-
config <- getPluginConfigAction plId
76-
if pluginEnabledConfig plcDiagnosticsOn config then do
90+
plugConfig <- getPluginConfigAction plId
91+
if pluginEnabledConfig plcDiagnosticsOn plugConfig then do
7792
maybeHie <- getHieFile file
7893
case maybeHie of
7994
Nothing -> return ([], Nothing)
8095
Just hie -> do
81-
let enabledInspections = HM.fromList [(LSP.fromNormalizedFilePath file, inspectionsIds)]
82-
-- This should use Cabal config for extensions and Stan config for inspection preferences is the future
83-
let analysis = runAnalysis Map.empty enabledInspections [] [hie]
96+
let currentHSfromHIEAbs = hie_hs_file hie
97+
currentHSfromHIERel <- liftIO $ makeRelativeToCurrentDirectory currentHSfromHIEAbs
98+
-- This codes follows what 'runStan' does, from the module 'Stan'
99+
100+
-- There aren't any cli args. isLoud=False=Silent output
101+
let isLoud = False -- Should this be enabled when debugging? Enables default stan cli output
102+
let stanArgsConfigFile = Nothing -- There aren't any cli args
103+
104+
EnvVars{envVarsUseDefaultConfigFile} <- liftIO getEnvVars
105+
logWith recorder Debug (LogDebug $
106+
"envVarsUseDefaultConfigFile: " <> (T.pack $ show envVarsUseDefaultConfigFile))
107+
108+
let defConfTrial = envVarsUseDefaultConfigFile -- There aren't any cli args: <> stanArgsUseDefaultConfigFile
109+
let useDefConfig = maybe True snd (trialToMaybe defConfTrial)
110+
111+
tomlConfig <- liftIO $ getTomlConfig isLoud useDefConfig stanArgsConfigFile
112+
let configTrial = finaliseConfig $ defaultConfig <> tomlConfig -- There aren't any cli args: <> stanArgsConfig
113+
logWith recorder Debug (LogDebug $ "Final stan config result\n" <> ( T.pack $ show configTrial))
114+
115+
(cabalExtensionsMap, checksMap, confIgnored) <- case configTrial of
116+
FiascoL es -> do
117+
logWith recorder Warning (LogWarnConf es)
118+
pure (Map.empty,
119+
HM.fromList [(LSP.fromNormalizedFilePath file, inspectionsIds)],
120+
[])
121+
ResultL warnings stanConfig -> do
122+
-- I'm not sure this is the best way to obtain the .cabal
123+
-- for this file but it'll have to do. Anyways, if it is not
124+
-- found it's not a big issue. That was the default previously.
125+
maybeCabalFileDir <- let maybeCabalFileDir = findFileUpwardsF
126+
(\fp -> takeExtension fp == ".cabal")
127+
currentHSfromHIEAbs
128+
in liftIO (mconcat . maybeToList <$> runMaybeT maybeCabalFileDir)
129+
cabalExtensionsMap <- liftIO $ case maybeCabalFileDir of
130+
[] -> do
131+
logWith recorder Warning LogWarnCabalNotFound
132+
pure Map.empty
133+
cabalFileDirs -> do
134+
logWith recorder Debug (LogDebug $
135+
"absolute cabalFilePath: " <> (T.pack $ show cabalFileDirs))
136+
createCabalExtensionsMap isLoud maybeCabalFileDir [hie]
137+
138+
-- Files (keys) in checksMap need to have an absolute path
139+
-- for the analysis, but applyConfig needs to receive relative
140+
-- filepaths to apply the config, because the toml config has
141+
-- relative paths. I'm not sure why that's a problem here and
142+
-- not in stan itself.
143+
let checksMap = HM.mapKeys (const currentHSfromHIEAbs) $ applyConfig [currentHSfromHIERel] stanConfig
144+
145+
logWith recorder Debug (LogDebug $
146+
"checksMap" <> (T.pack $ show checksMap))
147+
pure (cabalExtensionsMap, checksMap, configIgnored stanConfig)
148+
149+
let analysis = runAnalysis cabalExtensionsMap checksMap confIgnored [hie]
84150
return (analysisToDiagnostics file analysis, Just ())
85151
else return ([], Nothing)
86152

0 commit comments

Comments
 (0)