module Devtools.HLint (testTree) where

import Control.Applicative (empty, pure)
import Data.Function (($), (.), const)
import Data.Functor (void)
import Data.Semigroup ((<>))
import Data.String (String)
import Data.Typeable (Typeable)
import System.IO

import qualified Data.Foldable                      as Foldable
import qualified Language.Haskell.HLint             as HLint
import qualified System.Console.CmdArgs.Verbosity   as CmdArgs
import qualified Test.Tasty                         as Tasty
import qualified Test.Tasty.Providers               as Tasty
import qualified Test.Tasty.Providers.ConsoleFormat as Tasty

newtype HLintTest = HLintTest [String]
  deriving stock Typeable

instance Tasty.IsTest HLintTest where
  run :: OptionSet -> HLintTest -> (Progress -> IO ()) -> IO Result
run OptionSet
_options (HLintTest [String]
arguments) Progress -> IO ()
_callback = [String] -> IO Result
runHLintTest [String]
arguments
  testOptions :: Tagged HLintTest [OptionDescription]
testOptions = [OptionDescription] -> Tagged HLintTest [OptionDescription]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [OptionDescription]
forall (f :: * -> *) a. Alternative f => f a
empty

testTree :: [String] -> Tasty.TestTree
testTree :: [String] -> TestTree
testTree = String -> HLintTest -> TestTree
forall t. IsTest t => String -> t -> TestTree
Tasty.singleTest String
"hlint" (HLintTest -> TestTree)
-> ([String] -> HLintTest) -> [String] -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> HLintTest
HLintTest

runHLintTest :: [String] -> IO Tasty.Result
runHLintTest :: [String] -> IO Result
runHLintTest [String]
arguments = do
  [Idea]
ideas <- [String] -> IO [Idea]
HLint.hlint ([String] -> IO [Idea]) -> [String] -> IO [Idea]
forall a b. (a -> b) -> a -> b
$ [String
"--quiet"] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
arguments [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"."]

  Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ if [Idea] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Foldable.null [Idea]
ideas
    then String -> Result
Tasty.testPassed String
forall (f :: * -> *) a. Alternative f => f a
empty
    else String -> ResultDetailsPrinter -> Result
Tasty.testFailedDetails String
forall (f :: * -> *) a. Alternative f => f a
empty
      (ResultDetailsPrinter -> Result)
-> (IO () -> ResultDetailsPrinter) -> IO () -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> ConsoleFormatPrinter -> IO ()) -> ResultDetailsPrinter
Tasty.ResultDetailsPrinter
      ((Int -> ConsoleFormatPrinter -> IO ()) -> ResultDetailsPrinter)
-> (IO () -> Int -> ConsoleFormatPrinter -> IO ())
-> IO ()
-> ResultDetailsPrinter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConsoleFormatPrinter -> IO ())
-> Int -> ConsoleFormatPrinter -> IO ()
forall a b. a -> b -> a
const
      ((ConsoleFormatPrinter -> IO ())
 -> Int -> ConsoleFormatPrinter -> IO ())
-> (IO () -> ConsoleFormatPrinter -> IO ())
-> IO ()
-> Int
-> ConsoleFormatPrinter
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> ConsoleFormatPrinter -> IO ()
forall a b. a -> b -> a
const
      (IO () -> Result) -> IO () -> Result
forall a b. (a -> b) -> a -> b
$ [String] -> IO ()
runHLintVerbose [String]
arguments

-- Run HLint (again) but with output enabled.
-- There is no good public API in HLint to render the output.
runHLintVerbose :: [String] -> IO ()
runHLintVerbose :: [String] -> IO ()
runHLintVerbose [String]
arguments = do
  -- CmdArgs the CLI parsing lib for hlint leaks global state.
  -- We have to reset it here.
  Verbosity -> IO ()
CmdArgs.setVerbosity Verbosity
CmdArgs.Normal
  IO [Idea] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [Idea] -> IO ())
-> ([String] -> IO [Idea]) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> IO [Idea]
HLint.hlint ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [String]
arguments [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"--", String
"."]