{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- : out lint
-- : dep async
-- : dep regex-applicative
module Biz.Lint (main) where

import Alpha
import Biz.Namespace (Ext (..), Namespace (..))
import qualified Biz.Namespace as Namespace
import qualified Control.Concurrent.Async as Async
import qualified Data.String as String
import qualified Data.Text as Text
import qualified System.Console.Docopt as Docopt
import qualified System.Directory as Directory
import qualified System.Environment as Environment
import qualified System.Exit as Exit
import System.FilePath ((</>))
import qualified System.Process as Process

main :: IO ()
main =
  Environment.getArgs
    >>= Docopt.parseArgsOrExit help
    >>= (\args -> return <| Docopt.getAllArgs args (Docopt.argument "file"))
    >>= \case
      [] -> changedFiles >>= run >>= mapM printResult >>= exit
      files -> run (filter notcab files) >>= mapM printResult >>= exit

notcab :: FilePath -> Bool
notcab ('_' : _) = False
notcab _ = True

help :: Docopt.Docopt
help =
  [Docopt.docopt|
lint

Usage:
  lint [<file>...]
|]

exit :: [Result] -> IO ()
exit results = Exit.exitWith <| if n > 0 then Exit.ExitFailure n else Exit.ExitSuccess
  where
    n = length <| filter bad results
    bad (Error _) = False
    bad Ok {status = Bad _} = True
    bad _ = False

printResult :: Result -> IO Result
-- printResult r@(Error err) = (putText <| "lint: error: " <> err) >> pure r
printResult r@(Error err) = pure r
printResult r@(Ok path_ linter_ (Bad err)) =
  (putText <| "lint: badd: " <> Text.pack linter_ <> ": " <> Text.pack path_)
    >> if err == "" then pure r else putText (Text.pack err) >> pure r
printResult r@(Ok _ _ Good) = pure r
printResult r@(NoOp path_) =
  (putText <| "lint: noop: " <> Text.pack path_)
    >> pure r

changedFiles :: IO [FilePath]
changedFiles = mergeBase >>= changed
  where
    git args = Process.readProcess "git" args ""
    mergeBase = git ["merge-base", "HEAD", "origin/master"] /> filter (/= '\n')
    changed mb =
      String.lines
        </ git ["diff", "--name-only", "--diff-filter=d", mb]

type Linter = String

data Status = Good | Bad String
  deriving (Show)

data Result
  = Ok {path :: FilePath, linter :: Linter, status :: Status}
  | Error Text
  | NoOp FilePath
  deriving (Show)

run :: [FilePath] -> IO [Result]
run paths = do
  cwd <- Directory.getCurrentDirectory
  root <- Environment.getEnv "BIZ_ROOT"
  concat </ Async.mapConcurrently (runOne root cwd) paths

runOne :: FilePath -> FilePath -> FilePath -> IO [Result]
runOne root cwd path_ =
  sequence <| case Namespace.fromPath root (cwd </> path_) of
    Nothing -> [pure <. Error <| "could not get namespace for " <> Text.pack path_]
    Just (Namespace _ Hs) ->
      [ lint "ormolu" ["--mode", "check"] path_,
        lint "hlint" [] path_
      ]
    Just (Namespace _ Py) ->
      [ lint "pylint" ["--disable=invalid-name"] path_
      ]
    Just (Namespace _ Sh) -> [pure <| NoOp path_] -- [lint "shellcheck" [] path_]
    Just (Namespace _ Nix) -> [pure <| NoOp path_]
    Just (Namespace _ Scm) -> [pure <| NoOp path_]
    Just _ -> [pure <. Error <| "no linter for " <> Text.pack path_]

lint :: Linter -> [String] -> FilePath -> IO Result
lint bin args path_ =
  Process.readProcessWithExitCode bin (args ++ [path_]) "" >>= \case
    (Exit.ExitSuccess, _, _) -> pure <| Ok path_ bin Good
    (Exit.ExitFailure _, msg, _) ->
      pure <| Ok path_ bin <| Bad msg