Skip to content

Commit

Permalink
Use stan config files for stan plugin (haskell#3904)
Browse files Browse the repository at this point in the history
  • Loading branch information
@0rphee
0rphee committed Dec 18, 2023
1 parent 74466a9 commit a47af6e
Show file tree
Hide file tree
Showing 3 changed files with 133 additions and 46 deletions.
20 changes: 19 additions & 1 deletion ghcide/session-loader/Development/IDE/Session/Implicit.hs
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
module Development.IDE.Session.Implicit
( loadImplicitCradle
) where
, findFileUpwardsF) where


import Control.Applicative ((<|>))
Expand Down Expand Up @@ -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
Expand Down
3 changes: 3 additions & 0 deletions plugins/hls-stan-plugin/hls-stan-plugin.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -47,6 +47,9 @@ library
, transformers
, unordered-containers
, stan >= 0.1.1.0
, trial
, filepath
, directory

default-language: Haskell2010
default-extensions:
Expand Down
156 changes: 111 additions & 45 deletions plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs
View file
Original file line number Diff line number Diff line change
@@ -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)
Expand All @@ -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)
Expand All @@ -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)

Expand Down

0 comments on commit a47af6e

Please sign in to comment.