module Stan
( run
, createCabalExtensionsMap
) where
import Colourista (errorMessage, formatWith, infoMessage, italic, successMessage, warningMessage)
import System.Directory (doesFileExist, getCurrentDirectory)
import System.Environment (getArgs)
import System.FilePath (takeFileName)
import Trial (Trial (..), prettyTaggedTrial, prettyTrial, prettyTrialWith, trialToMaybe,
whenResult_)
import Stan.Analysis (Analysis (..), runAnalysis)
import Stan.Analysis.Pretty (prettyShowAnalysis)
import Stan.Cabal (createCabalExtensionsMap, usedCabalFiles)
import Stan.Cli (CliToTomlArgs (..), InspectionArgs (..), StanArgs (..), StanCommand (..),
TomlToCliArgs (..), runStanCli)
import Stan.Config (ConfigP (..), applyConfig, configToCliCommand, defaultConfig, finaliseConfig)
import Stan.Config.Pretty (prettyConfigCli)
import Stan.Core.Id (Id (..))
import Stan.EnvVars (EnvVars (..), envVarsToText, getEnvVars)
import Stan.Hie (readHieFiles)
import Stan.Hie.Compat (HieFile (..))
import Stan.Info (ProjectInfo (..), StanEnv (..))
import Stan.Inspection (Inspection (..), inspectionsMd, prettyShowInspection,
prettyShowInspectionShort)
import Stan.Inspection.All (getInspectionById, inspections, lookupInspectionById)
import Stan.Observation (Observation (..), prettyShowIgnoredObservations)
import Stan.Report (generateReport)
import Stan.Severity (Severity (Error))
import Stan.Toml (configCodec, getTomlConfig, usedTomlFiles)
import qualified Toml
run :: IO ()
run :: IO ()
run = IO StanCommand
runStanCli IO StanCommand -> (StanCommand -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Stan stanArgs :: StanArgs
stanArgs -> StanArgs -> IO ()
runStan StanArgs
stanArgs
StanInspection inspectionArgs :: InspectionArgs
inspectionArgs -> InspectionArgs -> IO ()
runInspection InspectionArgs
inspectionArgs
StanTomlToCli tomlToCliArgs :: TomlToCliArgs
tomlToCliArgs -> TomlToCliArgs -> IO ()
runTomlToCli TomlToCliArgs
tomlToCliArgs
StanCliToToml cliToTomlArgs :: CliToTomlArgs
cliToTomlArgs -> CliToTomlArgs -> IO ()
runCliToToml CliToTomlArgs
cliToTomlArgs
StanInspectionsToMd -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Inspection] -> Text
inspectionsMd [Inspection]
inspections
runStan :: StanArgs -> IO ()
runStan :: StanArgs -> IO ()
runStan StanArgs{..} = do
env :: EnvVars
env@EnvVars{..} <- IO EnvVars
getEnvVars
let defConfTrial :: TaggedTrial Text Bool
defConfTrial = TaggedTrial Text Bool
envVarsUseDefaultConfigFile TaggedTrial Text Bool
-> TaggedTrial Text Bool -> TaggedTrial Text Bool
forall a. Semigroup a => a -> a -> a
<> TaggedTrial Text Bool
stanArgsUseDefaultConfigFile
Text -> IO ()
infoMessage "Checking environment variables and CLI arguments for default configurations file usage..."
Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
indent (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ TaggedTrial Text Bool -> Text
forall a e.
(Show a, Semigroup e, IsString e) =>
TaggedTrial e a -> e
prettyTaggedTrial TaggedTrial Text Bool
defConfTrial
let useDefConfig :: Bool
useDefConfig = Bool -> ((Text, Bool) -> Bool) -> Maybe (Text, Bool) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Text, Bool) -> Bool
forall a b. (a, b) -> b
snd (TaggedTrial Text Bool -> Maybe (Text, Bool)
forall e a. Trial e a -> Maybe a
trialToMaybe TaggedTrial Text Bool
defConfTrial)
PartialConfig
tomlConfig <- Bool -> Maybe FilePath -> IO PartialConfig
getTomlConfig Bool
useDefConfig Maybe FilePath
stanArgsConfigFile
let configTrial :: Trial Text Config
configTrial = PartialConfig -> Trial Text Config
finaliseConfig (PartialConfig -> Trial Text Config)
-> PartialConfig -> Trial Text Config
forall a b. (a -> b) -> a -> b
$ PartialConfig
defaultConfig PartialConfig -> PartialConfig -> PartialConfig
forall a. Semigroup a => a -> a -> a
<> PartialConfig
tomlConfig PartialConfig -> PartialConfig -> PartialConfig
forall a. Semigroup a => a -> a -> a
<> PartialConfig
stanArgsConfig
Text -> IO ()
infoMessage "The following Configurations are used:\n"
Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
indent (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
forall a. ToString a => a -> FilePath
toString (Text -> FilePath) -> (Config -> Text) -> Config -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text
prettyConfigCli) Trial Text Config
configTrial
Trial Text Config -> ([Text] -> Config -> IO ()) -> IO ()
forall (f :: * -> *) e a.
Applicative f =>
Trial e a -> ([e] -> a -> f ()) -> f ()
whenResult_ Trial Text Config
configTrial (([Text] -> Config -> IO ()) -> IO ())
-> ([Text] -> Config -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \warnings :: [Text]
warnings config :: Config
config -> do
[HieFile]
hieFiles <- FilePath -> IO [HieFile]
readHieFiles FilePath
stanArgsHiedir
Map FilePath (Either ExtensionsError ParsedExtensions)
cabalExtensionsMap <- [FilePath]
-> [HieFile]
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
createCabalExtensionsMap [FilePath]
stanArgsCabalFilePath [HieFile]
hieFiles
let checksMap :: HashMap FilePath (HashSet (Id Inspection))
checksMap = [FilePath] -> Config -> HashMap FilePath (HashSet (Id Inspection))
applyConfig ((HieFile -> FilePath) -> [HieFile] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map HieFile -> FilePath
hie_hs_file [HieFile]
hieFiles) Config
config
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
config) [HieFile]
hieFiles
Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putText (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
indent (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Id Observation] -> Observations -> Text
prettyShowIgnoredObservations
(Config -> 'Final ::- [Id Observation]
forall (p :: Phase Text). ConfigP p -> p ::- [Id Observation]
configIgnored Config
config)
(Analysis -> Observations
analysisIgnoredObservations Analysis
analysis)
let observations :: Observations
observations = Analysis -> Observations
analysisObservations Analysis
analysis
let isNullObs :: Bool
isNullObs = Observations -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Observations
observations
if Bool
isNullObs
then Text -> IO ()
successMessage "All clean! Stan did not find any observations at the moment."
else Text -> IO ()
warningMessage "Stan found the following observations for the project:\n"
Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Analysis -> ReportSettings -> Text
prettyShowAnalysis Analysis
analysis ReportSettings
stanArgsReportSettings
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
stanArgsReport (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
FilePath
piName <- FilePath -> FilePath
takeFileName (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
getCurrentDirectory
[FilePath]
piCabalFiles <- [FilePath] -> IO [FilePath]
usedCabalFiles [FilePath]
stanArgsCabalFilePath
let piHieDir :: FilePath
piHieDir = FilePath
stanArgsHiedir
let piFileNumber :: Int
piFileNumber = [HieFile] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HieFile]
hieFiles
[FilePath]
seCliArgs <- IO [FilePath]
getArgs
[FilePath]
seTomlFiles <- Bool -> Maybe FilePath -> IO [FilePath]
usedTomlFiles Bool
useDefConfig Maybe FilePath
stanArgsConfigFile
let stanEnv :: StanEnv
stanEnv = $WStanEnv :: Text -> [FilePath] -> [FilePath] -> StanEnv
StanEnv
{ seEnvVars :: Text
seEnvVars = EnvVars -> Text
envVarsToText EnvVars
env
, ..
}
Analysis -> Config -> [Text] -> StanEnv -> ProjectInfo -> IO ()
generateReport Analysis
analysis Config
config [Text]
warnings StanEnv
stanEnv $WProjectInfo :: FilePath -> [FilePath] -> FilePath -> Int -> ProjectInfo
ProjectInfo{..}
Text -> IO ()
infoMessage "Report is generated here -> stan.html"
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
( Bool -> Bool
not Bool
isNullObs
Bool -> Bool -> Bool
&& (Observation -> Bool) -> Observations -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
>= Severity
Error) (Severity -> Bool)
-> (Observation -> Severity) -> Observation -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Observation -> Severity
getObservationSeverity) Observations
observations
)
IO ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
where
getObservationSeverity :: Observation -> Severity
getObservationSeverity :: Observation -> Severity
getObservationSeverity = Inspection -> Severity
inspectionSeverity (Inspection -> Severity)
-> (Observation -> Inspection) -> Observation -> Severity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id Inspection -> Inspection
getInspectionById (Id Inspection -> Inspection)
-> (Observation -> Id Inspection) -> Observation -> Inspection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Observation -> Id Inspection
observationInspectionId
indent :: Text -> Text
indent :: Text -> Text
indent = [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
forall t. IsText t "lines" => t -> [t]
lines
runInspection :: InspectionArgs -> IO ()
runInspection :: InspectionArgs -> IO ()
runInspection InspectionArgs{..} = case Maybe (Id Inspection)
inspectionArgsId of
Nothing -> [Inspection] -> (Inspection -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Inspection]
inspections (Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> (Inspection -> Text) -> Inspection -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inspection -> Text
prettyShowInspectionShort)
Just insId :: Id Inspection
insId -> case Id Inspection -> Maybe Inspection
lookupInspectionById Id Inspection
insId of
Just ins :: Inspection
ins -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Inspection -> Text
prettyShowInspection Inspection
ins
Nothing -> do
Text -> IO ()
errorMessage (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ "Inspection with such ID does not exist: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Id Inspection -> Text
forall a. Id a -> Text
unId Id Inspection
insId
Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ " 💡 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text -> Text
forall str. (IsString str, Semigroup str) => [str] -> str -> str
formatWith [Text
forall str. IsString str => str
italic] "Use 'stan inspection' to see the list of all available inspections."
runTomlToCli :: TomlToCliArgs -> IO ()
runTomlToCli :: TomlToCliArgs -> IO ()
runTomlToCli TomlToCliArgs{..} = do
let useDefConfig :: Bool
useDefConfig = Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isNothing Maybe FilePath
tomlToCliArgsFilePath
PartialConfig
partialConfig <- Bool -> Maybe FilePath -> IO PartialConfig
getTomlConfig Bool
useDefConfig Maybe FilePath
tomlToCliArgsFilePath
case PartialConfig -> Trial Text Config
finaliseConfig PartialConfig
partialConfig of
Result _ res :: Config
res -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Config -> Text
configToCliCommand Config
res
fiasco :: Trial Text Config
fiasco -> do
Text -> IO ()
errorMessage "Could not get Configurations:"
Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Trial Text Config -> Text
forall a e. (Show a, Semigroup e, IsString e) => Trial e a -> e
prettyTrial Trial Text Config
fiasco
runCliToToml :: CliToTomlArgs -> IO ()
runCliToToml :: CliToTomlArgs -> IO ()
runCliToToml CliToTomlArgs{..} = do
let toml :: Text
toml = TomlCodec PartialConfig -> PartialConfig -> Text
forall a. TomlCodec a -> a -> Text
Toml.encode TomlCodec PartialConfig
configCodec PartialConfig
cliToTomlArgsConfig
case Maybe FilePath
cliToTomlArgsFilePath of
Nothing -> do
Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn Text
toml
Text -> IO ()
infoMessage "Copy-paste the above TOML into .stan.toml and stan will pick up this file on the next run"
Just path :: FilePath
path -> do
Bool
isFile <- FilePath -> IO Bool
doesFileExist FilePath
path
if Bool
isFile
then Text -> IO ()
errorMessage (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ "Aborting writing to file because it already exists: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
path
else do
FilePath -> Text -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> Text -> m ()
writeFileText FilePath
path Text
toml
Text -> IO ()
infoMessage (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ "TOML configuration is written to file: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
path