{-# LANGUAGE OverloadedStrings #-}

{- | @pbt-cli doctor@: check that everything the tool needs is present and that
the repository in front of it is actually discoverable.

Modelled on the @--check-health@ mode of the shell tools it replaces, with the
same rule about what counts as a failure: only a missing *required* dependency
or an undiscoverable root is an error. Version strings are informational and
no minimum is ever enforced, because @pbt-cli@ only shells out to @cabal@ and
does not care which version answers.
-}
module PbtCli.Doctor (
  doctor,
  Check (..),
  Status (..),
) where

import Control.Exception (SomeException, try)
import Data.List (intercalate)
import PbtCli.Discover (Discovery (..), discover, flattenSuites, isCompatible, projectFilesIn, srSuite)
import System.Directory (doesDirectoryExist, findExecutable)
import System.Exit (ExitCode (..))
import System.Process (readProcess)

-- | How a single check turned out.
data Status
  = Ok
  | -- | present-but-notable, or an absent optional dependency.
    Warn
  | -- | a required dependency is missing, or the repo cannot be scanned.
    Missing
  deriving (Status -> Status -> Bool
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
/= :: Status -> Status -> Bool
Eq, Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Status -> ShowS
showsPrec :: Int -> Status -> ShowS
$cshow :: Status -> String
show :: Status -> String
$cshowList :: [Status] -> ShowS
showList :: [Status] -> ShowS
Show)

data Check = Check
  { Check -> String
chkName :: String
  , Check -> Status
chkStatus :: Status
  , Check -> String
chkDetail :: String
  }
  deriving (Check -> Check -> Bool
(Check -> Check -> Bool) -> (Check -> Check -> Bool) -> Eq Check
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Check -> Check -> Bool
== :: Check -> Check -> Bool
$c/= :: Check -> Check -> Bool
/= :: Check -> Check -> Bool
Eq, Int -> Check -> ShowS
[Check] -> ShowS
Check -> String
(Int -> Check -> ShowS)
-> (Check -> String) -> ([Check] -> ShowS) -> Show Check
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Check -> ShowS
showsPrec :: Int -> Check -> ShowS
$cshow :: Check -> String
show :: Check -> String
$cshowList :: [Check] -> ShowS
showList :: [Check] -> ShowS
Show)

{- | Run every check against @root@, print an aligned report, and return the
exit code: 'ExitFailure' @1@ if anything is 'Missing'.
-}
doctor :: FilePath -> IO ExitCode
doctor :: String -> IO ExitCode
doctor String
root = do
  [Check]
checks <- [IO Check] -> IO [Check]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [String -> IO Check
checkRoot String
root, IO Check
checkCabal, IO Check
checkGhc] IO [Check] -> ([Check] -> IO [Check]) -> IO [Check]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Check]
cs -> ([Check]
cs [Check] -> [Check] -> [Check]
forall a. Semigroup a => a -> a -> a
<>) ([Check] -> [Check]) -> IO [Check] -> IO [Check]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [Check]
repoChecks String
root
  String -> IO ()
putStrLn String
"pbt-cli — health check"
  String -> IO ()
putStrLn String
""
  (Check -> IO ()) -> [Check] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ()) -> (Check -> String) -> Check -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Check -> String
format) [Check]
checks
  String -> IO ()
putStrLn String
""
  let broken :: [Check]
broken = [Check
c | Check
c <- [Check]
checks, Check -> Status
chkStatus Check
c Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
Missing]
  if [Check] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Check]
broken
    then do
      String -> IO ()
putStrLn String
"All required dependencies present."
      ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
ExitSuccess
    else do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"Missing "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Check] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Check]
broken)
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" required item(s): "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Check -> String) -> [Check] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Check -> String
chkName [Check]
broken)
      ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> ExitCode
ExitFailure Int
1)
 where
  format :: Check -> String
format Check
c = Status -> String
tag (Check -> Status
chkStatus Check
c) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> ShowS
pad Int
14 (Check -> String
chkName Check
c) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Check -> String
chkDetail Check
c

  tag :: Status -> String
tag = \case
    Status
Ok -> String
"[  OK  ]"
    Status
Warn -> String
"[ WARN ]"
    Status
Missing -> String
"[MISSING]"

  pad :: Int -> ShowS
pad Int
n String
s = String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
' '

checkRoot :: FilePath -> IO Check
checkRoot :: String -> IO Check
checkRoot String
root = do
  Bool
exists <- String -> IO Bool
doesDirectoryExist String
root
  Check -> IO Check
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Check -> IO Check) -> Check -> IO Check
forall a b. (a -> b) -> a -> b
$
    if Bool
exists
      then String -> Status -> String -> Check
Check String
"root" Status
Ok String
root
      else String -> Status -> String -> Check
Check String
"root" Status
Missing (String
root String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not a directory")

-- | @cabal@ is required: every command except @suites@ shells out to it.
checkCabal :: IO Check
checkCabal :: IO Check
checkCabal = String -> Bool -> [String] -> IO Check
executableCheck String
"cabal" Bool
True [String
"--version"]

{- | @ghc@ is only a warning. @cabal@ can be configured with a compiler that is
not on @PATH@, so a missing @ghc@ here is a hint, not a verdict.
-}
checkGhc :: IO Check
checkGhc :: IO Check
checkGhc = String -> Bool -> [String] -> IO Check
executableCheck String
"ghc" Bool
False [String
"--version"]

executableCheck :: String -> Bool -> [String] -> IO Check
executableCheck :: String -> Bool -> [String] -> IO Check
executableCheck String
exe Bool
required [String]
args =
  String -> IO (Maybe String)
findExecutable String
exe IO (Maybe String) -> (Maybe String -> IO Check) -> IO Check
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe String
Nothing ->
      Check -> IO Check
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Check -> IO Check) -> (String -> Check) -> String -> IO Check
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Status -> String -> Check
Check String
exe (if Bool
required then Status
Missing else Status
Warn) (String -> IO Check) -> String -> IO Check
forall a b. (a -> b) -> a -> b
$
        String
"not found on PATH"
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> if Bool
required then String
"" else String
" (optional: cabal may use a compiler that is not on PATH)"
    Just String
path -> do
      Either SomeException String
out <- IO String -> IO (Either SomeException String)
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> [String] -> String -> IO String
readProcess String
path [String]
args String
"") :: IO (Either SomeException String)
      Check -> IO Check
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Check -> IO Check) -> (String -> Check) -> String -> IO Check
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Status -> String -> Check
Check String
exe Status
Ok (String -> IO Check) -> String -> IO Check
forall a b. (a -> b) -> a -> b
$ case Either SomeException String
out of
        Right String
s | (String
l : [String]
_) <- String -> [String]
lines String
s -> String
l
        Either SomeException String
_ -> String
path

{- | What the repository itself looks like: projects, suites, and how many of
those suites @pbt-cli@ can stream and discover tests in.
-}
repoChecks :: FilePath -> IO [Check]
repoChecks :: String -> IO [Check]
repoChecks String
root = do
  Bool
exists <- String -> IO Bool
doesDirectoryExist String
root
  if Bool -> Bool
not Bool
exists
    then [Check] -> IO [Check]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    else do
      [String]
projects <- String -> IO [String]
projectFilesIn String
root
      Discovery
d <- String -> IO Discovery
discover String
root
      let suites :: [SuiteRef]
suites = Discovery -> [SuiteRef]
flattenSuites Discovery
d
          compatible :: [SuiteRef]
compatible = (SuiteRef -> Bool) -> [SuiteRef] -> [SuiteRef]
forall a. (a -> Bool) -> [a] -> [a]
filter (TestSuite -> Bool
isCompatible (TestSuite -> Bool) -> (SuiteRef -> TestSuite) -> SuiteRef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SuiteRef -> TestSuite
srSuite) [SuiteRef]
suites
      [Check] -> IO [Check]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ String -> Status -> String -> Check
Check String
"projects" (if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
projects then Status
Warn else Status
Ok) (String -> Check) -> String -> Check
forall a b. (a -> b) -> a -> b
$
            if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
projects
              then String
"no cabal.project* found; treating every .cabal as one implicit project"
              else Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
projects) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
projects
        , String -> Status -> String -> Check
Check String
"test suites" (if [SuiteRef] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SuiteRef]
suites then Status
Warn else Status
Ok) (String -> Check) -> String -> Check
forall a b. (a -> b) -> a -> b
$
            Int -> String
forall a. Show a => a -> String
show ([SuiteRef] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SuiteRef]
suites) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" discovered"
        , String -> Status -> String -> Check
Check String
"pbt suites" (if [SuiteRef] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SuiteRef]
compatible then Status
Warn else Status
Ok) (String -> Check) -> String -> Check
forall a b. (a -> b) -> a -> b
$
            Int -> String
forall a. Show a => a -> String
show ([SuiteRef] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SuiteRef]
compatible)
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" sc-testing-tools compatible"
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> if [SuiteRef] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SuiteRef]
compatible
                then String
" (no suite uses defaultMainStreaming / defaultMainTestingInterface)"
                else String
""
        , String -> Status -> String -> Check
Check String
"orphans" (if [Orphan] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Discovery -> [Orphan]
discOrphans Discovery
d) then Status
Ok else Status
Warn) (String -> Check) -> String -> Check
forall a b. (a -> b) -> a -> b
$
            case Discovery -> [Orphan]
discOrphans Discovery
d of
              [] -> String
"none"
              [Orphan]
os -> Int -> String
forall a. Show a => a -> String
show ([Orphan] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Orphan]
os) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" .cabal file(s) referenced by no project"
        ]