{-# LANGUAGE CPP             #-}
{-# LANGUAGE PatternSynonyms #-}
module Ide.Plugin.Stan (descriptor, Log) where

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           Data.HashSet                   (HashSet)
import qualified Data.HashSet                   as HS
import qualified Data.Map                       as Map
import           Data.Maybe                     (fromJust, mapMaybe,
                                                 maybeToList)
import           Data.String                    (IsString (fromString))
import qualified Data.Text                      as T
import           Development.IDE
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,
                                                 srcSpanEndLine,
                                                 srcSpanStartCol,
                                                 srcSpanStartLine, tcg_exports)
import           Development.IDE.GHC.Error      (realSrcSpanToRange)
import           GHC.Generics                   (Generic)
import           Ide.Plugin.Config              (PluginConfig (..))
import           Ide.Types                      (PluginDescriptor (..),
                                                 PluginId, configHasDiagnostics,
                                                 configInitialGenericConfig,
                                                 defaultConfigDescriptor,
                                                 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 (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
plId = (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
desc)
  { pluginRules = rules recorder plId
  , 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 :: ConfigDescriptor
defConfigDescriptor = ConfigDescriptor
defaultConfigDescriptor
    desc :: Text
desc = Text
"Provides stan diagnostics. Built with stan-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VERSION_stan

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 :: Text -> Text
stripModifiers = Text -> Text -> Text
go Text
""
  where
    go :: Text -> Text -> Text
go Text
acc Text
txt =
      case (Char -> Bool) -> Text -> Maybe Int
T.findIndex (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\x1B') Text
txt of
        Maybe Int
Nothing -> Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt
        Just Int
index -> let (Text
beforeEsc, Text
afterEsc) = Int -> Text -> (Text, Text)
T.splitAt Int
index Text
txt
                      in Text -> Text -> Text
go (Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
beforeEsc) (Text -> Text
consumeEscapeSequence Text
afterEsc)
    consumeEscapeSequence :: T.Text -> T.Text
    consumeEscapeSequence :: Text -> Text
consumeEscapeSequence Text
txt =
      case (Char -> Bool) -> Text -> Maybe Int
T.findIndex (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'm') Text
txt of
        Maybe Int
Nothing    -> Text
txt
        Just Int
index -> Int -> Text -> Text
T.drop (Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
txt

renderId :: Id a -> T.Text
renderId :: forall a. Id a -> Text
renderId (Id Text
t) = Text
"Id = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogShake Log
log -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
log
    LogWarnConf [(Fatality, Text)]
errs -> Doc ann
"Fiasco encountered when trying to load stan configuration. Using default inspections:"
                        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Doc ann
forall ann. FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FilePath -> Doc ann) -> FilePath -> Doc ann
forall a b. (a -> b) -> a -> b
$ [(Fatality, Text)] -> FilePath
forall a. Show a => a -> FilePath
show [(Fatality, Text)]
errs)
    LogDebugStanConfigResult [FilePath]
fps Trial Text Config
t -> Doc ann
"Config result using: "
                                      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> Doc ann
forall ann. [FilePath] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [FilePath]
fps Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Text
stripModifiers (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Config -> FilePath) -> Trial Text Config -> Text
forall e a.
(Semigroup e, IsString e) =>
(a -> FilePath) -> Trial e a -> e
prettyTrialWith (Text -> FilePath
T.unpack (Text -> FilePath) -> (Config -> Text) -> Config -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text
prettyConfigCli) Trial Text Config
t)
    LogDebugStanEnvVars EnvVars
envVars -> Doc ann
"EnvVars " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
        case EnvVars
envVars of
            EnvVars trial :: TaggedTrial Text Bool
trial@(FiascoL [(Fatality, Text)]
_) -> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Text
stripModifiers (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ TaggedTrial Text Bool -> Text
forall a e. (Show a, Semigroup e, IsString e) => Trial e a -> e
prettyTrial TaggedTrial Text Bool
trial)

            -- if the envVars are not set, 'envVarsToText returns an empty string'
            EnvVars
_ -> Doc ann
"found: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ EnvVars -> Text
envVarsToText EnvVars
envVars)

data GetStanDiagnostics = GetStanDiagnostics
  deriving (GetStanDiagnostics -> GetStanDiagnostics -> Bool
(GetStanDiagnostics -> GetStanDiagnostics -> Bool)
-> (GetStanDiagnostics -> GetStanDiagnostics -> Bool)
-> Eq GetStanDiagnostics
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GetStanDiagnostics -> GetStanDiagnostics -> Bool
== :: GetStanDiagnostics -> GetStanDiagnostics -> Bool
$c/= :: GetStanDiagnostics -> GetStanDiagnostics -> Bool
/= :: GetStanDiagnostics -> GetStanDiagnostics -> Bool
Eq, Int -> GetStanDiagnostics -> ShowS
[GetStanDiagnostics] -> ShowS
GetStanDiagnostics -> FilePath
(Int -> GetStanDiagnostics -> ShowS)
-> (GetStanDiagnostics -> FilePath)
-> ([GetStanDiagnostics] -> ShowS)
-> Show GetStanDiagnostics
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GetStanDiagnostics -> ShowS
showsPrec :: Int -> GetStanDiagnostics -> ShowS
$cshow :: GetStanDiagnostics -> FilePath
show :: GetStanDiagnostics -> FilePath
$cshowList :: [GetStanDiagnostics] -> ShowS
showList :: [GetStanDiagnostics] -> ShowS
Show, (forall x. GetStanDiagnostics -> Rep GetStanDiagnostics x)
-> (forall x. Rep GetStanDiagnostics x -> GetStanDiagnostics)
-> Generic GetStanDiagnostics
forall x. Rep GetStanDiagnostics x -> GetStanDiagnostics
forall x. GetStanDiagnostics -> Rep GetStanDiagnostics x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GetStanDiagnostics -> Rep GetStanDiagnostics x
from :: forall x. GetStanDiagnostics -> Rep GetStanDiagnostics x
$cto :: forall x. Rep GetStanDiagnostics x -> GetStanDiagnostics
to :: forall x. Rep GetStanDiagnostics x -> GetStanDiagnostics
Generic)

instance Hashable GetStanDiagnostics

instance NFData GetStanDiagnostics

type instance RuleResult GetStanDiagnostics = ()

rules :: Recorder (WithPriority Log) -> PluginId -> Rules ()
rules :: Recorder (WithPriority Log) -> PluginId -> Rules ()
rules Recorder (WithPriority Log)
recorder PluginId
plId = do
  Recorder (WithPriority Log)
-> (GetStanDiagnostics
    -> NormalizedFilePath -> Action (IdeResult ()))
-> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) ((GetStanDiagnostics
  -> NormalizedFilePath -> Action (IdeResult ()))
 -> Rules ())
-> (GetStanDiagnostics
    -> NormalizedFilePath -> Action (IdeResult ()))
-> Rules ()
forall a b. (a -> b) -> a -> b
$
    \GetStanDiagnostics
GetStanDiagnostics NormalizedFilePath
file -> do
      PluginConfig
config <- PluginId -> Action PluginConfig
getPluginConfigAction PluginId
plId
      if PluginConfig -> Bool
plcGlobalOn PluginConfig
config Bool -> Bool -> Bool
&& PluginConfig -> Bool
plcDiagnosticsOn PluginConfig
config then do
          Maybe HieFile
maybeHie <- NormalizedFilePath -> Action (Maybe HieFile)
getHieFile NormalizedFilePath
file
          case Maybe HieFile
maybeHie of
            Maybe HieFile
Nothing -> IdeResult () -> Action (IdeResult ())
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Maybe ()
forall a. Maybe a
Nothing)
            Just HieFile
hie -> do
              let isLoud :: Bool
isLoud = Bool
False -- in Stan: notJson = not isLoud
              let stanArgs :: StanArgs
stanArgs =
                      StanArgs
                          { stanArgsHiedir :: FilePath
stanArgsHiedir               = FilePath
"" -- :: !FilePath  -- ^ Directory with HIE files
                          , stanArgsCabalFilePath :: [FilePath]
stanArgsCabalFilePath        = [] -- :: ![FilePath]  -- ^ Path to @.cabal@ files.
                          , stanArgsOutputSettings :: OutputSettings
stanArgsOutputSettings       = Verbosity -> ToggleSolution -> OutputSettings
OutputSettings Verbosity
NonVerbose ToggleSolution
ShowSolution -- :: !OutputSettings  -- ^ Settings for output terminal report
                                                                                                  -- doesnt matter, because it is silenced by isLoud
                          , stanArgsReport :: Maybe ReportArgs
stanArgsReport               = Maybe ReportArgs
forall a. Maybe a
Nothing -- :: !(Maybe ReportArgs)  -- ^ @HTML@ report settings
                          , stanArgsUseDefaultConfigFile :: TaggedTrial Text Bool
stanArgsUseDefaultConfigFile = Text -> TaggedTrial Text Bool
forall e a. e -> Trial e a
fiasco Text
"" -- :: !(TaggedTrial Text Bool)  -- ^ Use default @.stan.toml@ file
                          , stanArgsConfigFile :: Maybe FilePath
stanArgsConfigFile           = Maybe FilePath
forall a. Maybe a
Nothing -- :: !(Maybe FilePath)  -- ^ Path to a custom configurations file.
                          , stanArgsConfig :: PartialConfig
stanArgsConfig               = ConfigP
                                                            { configChecks :: 'Partial ::- [Check]
configChecks  = Text -> Trial Text (Text, [Check])
forall e a. e -> Trial e a
fiasco Text
"'hls-stan-plugin' doesn't receive CLI options for: checks"
                                                            , configRemoved :: 'Partial ::- [Scope]
configRemoved = Text -> Trial Text (Text, [Scope])
forall e a. e -> Trial e a
fiasco Text
"'hls-stan-plugin' doesn't receive CLI options for: remove"
                                                            , configIgnored :: 'Partial ::- [Id Observation]
configIgnored = Text -> Trial Text (Text, [Id Observation])
forall e a. e -> Trial e a
fiasco Text
"'hls-stan-plugin' doesn't receive CLI options for: ignore"
                                                            }
                                                            -- if they are not fiascos, .stan.toml's aren't taken into account
                          ,stanArgsJsonOut :: Bool
stanArgsJsonOut              = Bool -> Bool
not Bool
isLoud -- :: !Bool  -- ^ Output the machine-readable output in JSON format instead.
                          }

              (Trial Text Config
configTrial, Bool
useDefConfig, EnvVars
env) <- IO (Trial Text Config, Bool, EnvVars)
-> Action (Trial Text Config, Bool, EnvVars)
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Trial Text Config, Bool, EnvVars)
 -> Action (Trial Text Config, Bool, EnvVars))
-> IO (Trial Text Config, Bool, EnvVars)
-> Action (Trial Text Config, Bool, EnvVars)
forall a b. (a -> b) -> a -> b
$ StanArgs -> Bool -> IO (Trial Text Config, Bool, EnvVars)
getStanConfig StanArgs
stanArgs Bool
isLoud
              [FilePath]
seTomlFiles <- IO [FilePath] -> Action [FilePath]
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> Action [FilePath])
-> IO [FilePath] -> Action [FilePath]
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe FilePath -> IO [FilePath]
usedTomlFiles Bool
useDefConfig (StanArgs -> Maybe FilePath
stanArgsConfigFile StanArgs
stanArgs)
              Recorder (WithPriority Log) -> Priority -> Log -> Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug ([FilePath] -> Trial Text Config -> Log
LogDebugStanConfigResult [FilePath]
seTomlFiles Trial Text Config
configTrial)

              -- If envVar is set to 'False', stan will ignore all local and global .stan.toml files
              Recorder (WithPriority Log) -> Priority -> Log -> Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (EnvVars -> Log
LogDebugStanEnvVars EnvVars
env)
              [FilePath]
seTomlFiles <- IO [FilePath] -> Action [FilePath]
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> Action [FilePath])
-> IO [FilePath] -> Action [FilePath]
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe FilePath -> IO [FilePath]
usedTomlFiles Bool
useDefConfig (StanArgs -> Maybe FilePath
stanArgsConfigFile StanArgs
stanArgs)

              (Map FilePath (Either ExtensionsError ParsedExtensions)
cabalExtensionsMap, HashMap FilePath (HashSet (Id Inspection))
checksMap, [Id Observation]
confIgnored) <- case Trial Text Config
configTrial of
                  FiascoL [(Fatality, Text)]
es -> do
                      Recorder (WithPriority Log) -> Priority -> Log -> Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Development.IDE.Warning ([(Fatality, Text)] -> Log
LogWarnConf [(Fatality, Text)]
es)
                      (Map FilePath (Either ExtensionsError ParsedExtensions),
 HashMap FilePath (HashSet (Id Inspection)), [Id Observation])
-> Action
     (Map FilePath (Either ExtensionsError ParsedExtensions),
      HashMap FilePath (HashSet (Id Inspection)), [Id Observation])
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map FilePath (Either ExtensionsError ParsedExtensions)
forall k a. Map k a
Map.empty,
                            [(FilePath, HashSet (Id Inspection))]
-> HashMap FilePath (HashSet (Id Inspection))
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(NormalizedFilePath -> FilePath
LSP.fromNormalizedFilePath NormalizedFilePath
file, HashSet (Id Inspection)
inspectionsIds)],
                            [])
                  ResultL [Text]
warnings Config
stanConfig -> do
                      let currentHSAbs :: FilePath
currentHSAbs = NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
file -- hie_hs_file hie
                      FilePath
currentHSRel <- IO FilePath -> Action FilePath
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> Action FilePath) -> IO FilePath -> Action FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
makeRelativeToCurrentDirectory FilePath
currentHSAbs
                      Map FilePath (Either ExtensionsError ParsedExtensions)
cabalExtensionsMap <- IO (Map FilePath (Either ExtensionsError ParsedExtensions))
-> Action (Map FilePath (Either ExtensionsError ParsedExtensions))
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map FilePath (Either ExtensionsError ParsedExtensions))
 -> Action (Map FilePath (Either ExtensionsError ParsedExtensions)))
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
-> Action (Map FilePath (Either ExtensionsError ParsedExtensions))
forall a b. (a -> b) -> a -> b
$ Bool
-> [FilePath]
-> [HieFile]
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
createCabalExtensionsMap Bool
isLoud (StanArgs -> [FilePath]
stanArgsCabalFilePath StanArgs
stanArgs) [HieFile
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 :: HashMap FilePath (HashSet (Id Inspection))
checksMap = ShowS
-> HashMap FilePath (HashSet (Id Inspection))
-> HashMap FilePath (HashSet (Id Inspection))
forall k2 k1 v.
(Eq k2, Hashable k2) =>
(k1 -> k2) -> HashMap k1 v -> HashMap k2 v
HM.mapKeys (FilePath -> ShowS
forall a b. a -> b -> a
const FilePath
currentHSAbs) (HashMap FilePath (HashSet (Id Inspection))
 -> HashMap FilePath (HashSet (Id Inspection)))
-> HashMap FilePath (HashSet (Id Inspection))
-> HashMap FilePath (HashSet (Id Inspection))
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Config -> HashMap FilePath (HashSet (Id Inspection))
applyConfig [FilePath
currentHSRel] Config
stanConfig

                      let analysis :: Analysis
analysis = Map FilePath (Either ExtensionsError ParsedExtensions)
-> HashMap FilePath (HashSet (Id Inspection))
-> [Id Observation]
-> [HieFile]
-> Analysis
runAnalysis Map FilePath (Either ExtensionsError ParsedExtensions)
cabalExtensionsMap HashMap FilePath (HashSet (Id Inspection))
checksMap (Config -> 'Final ::- [Id Observation]
forall (p :: Phase Text). ConfigP p -> p ::- [Id Observation]
configIgnored Config
stanConfig) [HieFile
hie]
                      (Map FilePath (Either ExtensionsError ParsedExtensions),
 HashMap FilePath (HashSet (Id Inspection)), [Id Observation])
-> Action
     (Map FilePath (Either ExtensionsError ParsedExtensions),
      HashMap FilePath (HashSet (Id Inspection)), [Id Observation])
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map FilePath (Either ExtensionsError ParsedExtensions)
cabalExtensionsMap, HashMap FilePath (HashSet (Id Inspection))
checksMap, Config -> 'Final ::- [Id Observation]
forall (p :: Phase Text). ConfigP p -> p ::- [Id Observation]
configIgnored Config
stanConfig)
              let analysis :: Analysis
analysis = Map FilePath (Either ExtensionsError ParsedExtensions)
-> HashMap FilePath (HashSet (Id Inspection))
-> [Id Observation]
-> [HieFile]
-> Analysis
runAnalysis Map FilePath (Either ExtensionsError ParsedExtensions)
cabalExtensionsMap HashMap FilePath (HashSet (Id Inspection))
checksMap [Id Observation]
confIgnored [HieFile
hie]
              IdeResult () -> Action (IdeResult ())
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (NormalizedFilePath -> Analysis -> [FileDiagnostic]
analysisToDiagnostics NormalizedFilePath
file Analysis
analysis, () -> Maybe ()
forall a. a -> Maybe a
Just ())
      else IdeResult () -> Action (IdeResult ())
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Maybe ()
forall a. Maybe a
Nothing)

  Action () -> Rules ()
forall a. Action a -> Rules ()
action (Action () -> Rules ()) -> Action () -> Rules ()
forall a b. (a -> b) -> a -> b
$ do
    HashMap NormalizedFilePath FileOfInterestStatus
files <- Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterestUntracked
    Action [Maybe ()] -> Action ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Action [Maybe ()] -> Action ()) -> Action [Maybe ()] -> Action ()
forall a b. (a -> b) -> a -> b
$ GetStanDiagnostics -> [NormalizedFilePath] -> Action [Maybe ()]
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GetStanDiagnostics
GetStanDiagnostics ([NormalizedFilePath] -> Action [Maybe ()])
-> [NormalizedFilePath] -> Action [Maybe ()]
forall a b. (a -> b) -> a -> b
$ HashMap NormalizedFilePath FileOfInterestStatus
-> [NormalizedFilePath]
forall k v. HashMap k v -> [k]
HM.keys HashMap NormalizedFilePath FileOfInterestStatus
files
  where
    analysisToDiagnostics :: NormalizedFilePath -> Analysis -> [FileDiagnostic]
    analysisToDiagnostics :: NormalizedFilePath -> Analysis -> [FileDiagnostic]
analysisToDiagnostics NormalizedFilePath
file = (Observation -> Maybe FileDiagnostic)
-> [Observation] -> [FileDiagnostic]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NormalizedFilePath -> Observation -> Maybe FileDiagnostic
observationToDianostic NormalizedFilePath
file) ([Observation] -> [FileDiagnostic])
-> (Analysis -> [Observation]) -> Analysis -> [FileDiagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Slist Observation -> [Observation]
forall a. Slist a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Slist Observation -> [Observation])
-> (Analysis -> Slist Observation) -> Analysis -> [Observation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Analysis -> Slist Observation
analysisObservations
    observationToDianostic :: NormalizedFilePath -> Observation -> Maybe FileDiagnostic
    observationToDianostic :: NormalizedFilePath -> Observation -> Maybe FileDiagnostic
observationToDianostic NormalizedFilePath
file Observation {RealSrcSpan
observationSrcSpan :: RealSrcSpan
observationSrcSpan :: Observation -> RealSrcSpan
observationSrcSpan, Id Inspection
observationInspectionId :: Id Inspection
observationInspectionId :: Observation -> Id Inspection
observationInspectionId} =
      do
        Inspection
inspection <- Id Inspection
-> HashMap (Id Inspection) Inspection -> Maybe Inspection
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Id Inspection
observationInspectionId HashMap (Id Inspection) Inspection
inspectionsMap
        let
          -- Looking similar to Stan CLI output
          -- We do not use `prettyShowInspection` cuz Id is redundant here
          -- `prettyShowSeverity` and `prettyShowCategory` would contain color
          -- codes and are replaced, too
          message :: T.Text
          message :: Text
message =
            [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
              [ Text
" ✲ Name:        " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Inspection -> Text
inspectionName Inspection
inspection,
                Text
" ✲ Description: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Inspection -> Text
inspectionDescription Inspection
inspection,
                Text
" ✲ Severity:    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Severity -> FilePath
forall a. Show a => a -> FilePath
show (Severity -> FilePath) -> Severity -> FilePath
forall a b. (a -> b) -> a -> b
$ Inspection -> Severity
inspectionSeverity Inspection
inspection),
                Text
" ✲ Category:    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" "
                  ((Category -> Text) -> [Category] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Category -> Text) -> Category -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Category -> Text
unCategory) ([Category] -> [Text]) -> [Category] -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty Category -> [Category]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Category -> [Category])
-> NonEmpty Category -> [Category]
forall a b. (a -> b) -> a -> b
$ Inspection -> NonEmpty Category
inspectionCategory Inspection
inspection),
                Text
"Possible solutions:"
              ]
                [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"  - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Inspection -> [Text]
inspectionSolution Inspection
inspection)
        FileDiagnostic -> Maybe FileDiagnostic
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ( NormalizedFilePath
file,
          ShowDiagnostic
ShowDiag,
          LSP.Diagnostic
            { $sel:_range:Diagnostic :: Range
_range = RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
observationSrcSpan,
              $sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
LSP.DiagnosticSeverity_Hint,
              $sel:_code:Diagnostic :: Maybe (Int32 |? Text)
_code = (Int32 |? Text) -> Maybe (Int32 |? Text)
forall a. a -> Maybe a
Just (Text -> Int32 |? Text
forall a b. b -> a |? b
LSP.InR (Text -> Int32 |? Text) -> Text -> Int32 |? Text
forall a b. (a -> b) -> a -> b
$ Id Inspection -> Text
forall a. Id a -> Text
unId (Inspection -> Id Inspection
inspectionId Inspection
inspection)),
              $sel:_source:Diagnostic :: Maybe Text
_source = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"stan",
              $sel:_message:Diagnostic :: Text
_message = Text
message,
              $sel:_relatedInformation:Diagnostic :: Maybe [DiagnosticRelatedInformation]
_relatedInformation = Maybe [DiagnosticRelatedInformation]
forall a. Maybe a
Nothing,
              $sel:_tags:Diagnostic :: Maybe [DiagnosticTag]
_tags = Maybe [DiagnosticTag]
forall a. Maybe a
Nothing,
              $sel:_codeDescription:Diagnostic :: Maybe CodeDescription
_codeDescription = Maybe CodeDescription
forall a. Maybe a
Nothing,
              $sel:_data_:Diagnostic :: Maybe Value
_data_ = Maybe Value
forall a. Maybe a
Nothing
            }
          )