{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

module Krank
  ( runKrank,
    Krank (..),
  )
where

import Control.Concurrent.Async.Lifted (mapConcurrently)
import Control.Exception.Safe
import Control.Monad.Reader
import qualified Data.ByteString
import Data.Coerce
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import Krank.Checkers.Ignore (filterViolations)
import qualified Krank.Checkers.IssueTracker as IT
import Krank.Formatter
import Krank.Types
import qualified Network.HTTP.Req as Req
import PyF
import System.IO (stderr)

processFile ::
  MonadKrank m =>
  -- | the file to analyze
  FilePath ->
  m [Violation]
processFile :: forall (m :: * -> *). MonadKrank m => FilePath -> m [Violation]
processFile FilePath
filePath = do
  ByteString
content <- forall (m :: * -> *). MonadKrank m => FilePath -> m ByteString
krankReadFile FilePath
filePath
  [Violation]
violations <- forall (m :: * -> *).
MonadKrank m =>
FilePath -> ByteString -> m [Violation]
IT.checkText FilePath
filePath ByteString
content
  let filtered :: [Violation]
filtered = [Violation] -> FilePath -> ByteString -> [Violation]
filterViolations [Violation]
violations FilePath
filePath ByteString
content
  -- forcing 'violations' to WHNF forces more of the processing to happen inside the thread and
  -- improves a bit the runtime performances in parallel.
  -- forcing to Normal Form (with deepseq) does not bring anymore improvement
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! [Violation]
filtered

runKrank :: MonadKrank m => [FilePath] -> m Bool
runKrank :: forall (m :: * -> *). MonadKrank m => [FilePath] -> m Bool
runKrank [FilePath]
paths = do
  KrankConfig {Bool
useColors :: KrankConfig -> Bool
useColors :: Bool
useColors} <- forall (m :: * -> *) b. MonadKrank m => (KrankConfig -> b) -> m b
krankAsks forall a. a -> a
id
  [Either Text [Violation]]
res <- forall (m :: * -> *) a b.
MonadKrank m =>
[a] -> (a -> m b) -> m [b]
krankForConcurrently [FilePath]
paths forall a b. (a -> b) -> a -> b
$ \FilePath
path ->
    (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadKrank m => FilePath -> m [Violation]
processFile FilePath
path)
      forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (\(SomeException e
e) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [fmt|Error when processing {path}: {show e}|])
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Either Text [Violation]]
res forall a b. (a -> b) -> a -> b
$ \case
    Left Text
err -> forall (m :: * -> *). MonadKrank m => Text -> m ()
krankPutStrLnStderr Text
err
    Right [Violation]
violations -> forall (m :: * -> *). MonadKrank m => Text -> m ()
krankPutStr (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Bool -> Violation -> Text
showViolation Bool
useColors) [Violation]
violations)
  -- Check if any violation is an error
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either Text [Violation] -> Bool
isError [Either Text [Violation]]
res)

-- | Returns 'True' if any violation level is error or if any error occurs.
isError :: Either Text.Text [Violation] -> Bool
isError :: Either Text [Violation] -> Bool
isError (Left Text
_) = Bool
True
isError (Right [Violation]
violations) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Violation -> Bool
isViolationError [Violation]
violations

isViolationError :: Violation -> Bool
isViolationError :: Violation -> Bool
isViolationError Violation {level :: Violation -> ViolationLevel
level = ViolationLevel
Error} = Bool
True
isViolationError Violation
_ = Bool
False

-- | This just exists to avoid the orphan instance on MonadKrank
newtype Krank t = Krank {forall t. Krank t -> ReaderT KrankConfig IO t
unKrank :: ReaderT KrankConfig IO t}
  deriving newtype (forall a b. a -> Krank b -> Krank a
forall a b. (a -> b) -> Krank a -> Krank b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Krank b -> Krank a
$c<$ :: forall a b. a -> Krank b -> Krank a
fmap :: forall a b. (a -> b) -> Krank a -> Krank b
$cfmap :: forall a b. (a -> b) -> Krank a -> Krank b
Functor, Functor Krank
forall a. a -> Krank a
forall a b. Krank a -> Krank b -> Krank a
forall a b. Krank a -> Krank b -> Krank b
forall a b. Krank (a -> b) -> Krank a -> Krank b
forall a b c. (a -> b -> c) -> Krank a -> Krank b -> Krank c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Krank a -> Krank b -> Krank a
$c<* :: forall a b. Krank a -> Krank b -> Krank a
*> :: forall a b. Krank a -> Krank b -> Krank b
$c*> :: forall a b. Krank a -> Krank b -> Krank b
liftA2 :: forall a b c. (a -> b -> c) -> Krank a -> Krank b -> Krank c
$cliftA2 :: forall a b c. (a -> b -> c) -> Krank a -> Krank b -> Krank c
<*> :: forall a b. Krank (a -> b) -> Krank a -> Krank b
$c<*> :: forall a b. Krank (a -> b) -> Krank a -> Krank b
pure :: forall a. a -> Krank a
$cpure :: forall a. a -> Krank a
Applicative, Applicative Krank
forall a. a -> Krank a
forall a b. Krank a -> Krank b -> Krank b
forall a b. Krank a -> (a -> Krank b) -> Krank b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Krank a
$creturn :: forall a. a -> Krank a
>> :: forall a b. Krank a -> Krank b -> Krank b
$c>> :: forall a b. Krank a -> Krank b -> Krank b
>>= :: forall a b. Krank a -> (a -> Krank b) -> Krank b
$c>>= :: forall a b. Krank a -> (a -> Krank b) -> Krank b
Monad, MonadThrow Krank
forall e a. Exception e => Krank a -> (e -> Krank a) -> Krank a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: forall e a. Exception e => Krank a -> (e -> Krank a) -> Krank a
$ccatch :: forall e a. Exception e => Krank a -> (e -> Krank a) -> Krank a
MonadCatch, Monad Krank
forall e a. Exception e => e -> Krank a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> Krank a
$cthrowM :: forall e a. Exception e => e -> Krank a
MonadThrow)

-- | The real monad implementation for Krank
instance MonadKrank Krank where
  krankReadFile :: FilePath -> Krank ByteString
krankReadFile = forall t. ReaderT KrankConfig IO t -> Krank t
Krank forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
Data.ByteString.readFile

  krankAsks :: forall b. (KrankConfig -> b) -> Krank b
krankAsks = forall t. ReaderT KrankConfig IO t -> Krank t
Krank forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks

  krankPutStrLnStderr :: Text -> Krank ()
krankPutStrLnStderr = forall t. ReaderT KrankConfig IO t -> Krank t
Krank forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
Text.IO.hPutStrLn Handle
stderr

  krankPutStr :: Text -> Krank ()
krankPutStr = forall t. ReaderT KrankConfig IO t -> Krank t
Krank forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
Text.IO.putStr

  -- Use threads for concurrency
  krankMapConcurrently :: forall a b. (a -> Krank b) -> [a] -> Krank [b]
krankMapConcurrently a -> Krank b
f [a]
l = forall t. ReaderT KrankConfig IO t -> Krank t
Krank forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, MonadBaseControl IO m) =>
(a -> m b) -> t a -> m (t b)
mapConcurrently (coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Krank b
f) [a]
l

  -- This implements a Req REST request
  krankRunRESTRequest :: forall t. FromJSON t => Url 'Https -> Option 'Https -> Krank t
krankRunRESTRequest Url 'Https
url Option 'Https
headers = forall t. ReaderT KrankConfig IO t -> Krank t
Krank forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
Req.runReq HttpConfig
Req.defaultHttpConfig forall a b. (a -> b) -> a -> b
$
      do
        JsonResponse t
r <-
          forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
Req.req
            GET
Req.GET
            Url 'Https
url
            NoReqBody
Req.NoReqBody
            forall a. Proxy (JsonResponse a)
Req.jsonResponse
            ( forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
Req.header ByteString
"User-Agent" ByteString
"krank"
                forall a. Semigroup a => a -> a -> a
<> Option 'Https
headers
            )
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall response.
HttpResponse response =>
response -> HttpResponseBody response
Req.responseBody JsonResponse t
r