path: root/Biz/Lint.hs

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

-- : out lint
--
-- these are actually runtime deps, but bild doesn't (yet) distinguish between
-- rundeps and sysdeps:
--
-- : sys ormolu
-- : sys hlint
-- : sys black
-- : sys ruff
-- : sys deadnix
-- : sys shellcheck
-- : sys indent
module Biz.Lint (main) where

import Alpha
import qualified Biz.Cli as Cli
import qualified Biz.Log as Log
import Biz.Namespace (Ext (..), Namespace (..))
import qualified Biz.Namespace as Namespace
import Biz.Test ((@=?))
import qualified Biz.Test as Test
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Char8 as Char8
import qualified Data.Map as Map
import qualified Data.String as String
import qualified Data.Text as Text
import qualified System.Directory as Directory
import qualified System.Environment as Environment
import qualified System.Exit as Exit
import qualified System.Process as Process

main :: IO ()
main = Cli.main <| Cli.Plan help move test pure

move :: Cli.Arguments -> IO ()
move args =
  Environment.getEnv "BIZ_ROOT" +> \root ->
    case Cli.getAllArgs args (Cli.argument "file") of
      [] ->
        changedFiles
          +> traverse Directory.makeAbsolute
          /> map (Namespace.fromPath root)
          /> catMaybes
          /> Namespace.groupByExt
          +> run mode
          +> exit
      files ->
        files
          |> filter (not <. Namespace.isCab)
          |> traverse Directory.makeAbsolute
          +> filterM Directory.doesFileExist
          /> map (Namespace.fromPath root)
          /> catMaybes
          /> Namespace.groupByExt
          +> run mode
          +> exit
  where
    mode = args `Cli.has` Cli.longOption "fix" ?: (Fix, Check)

test :: Test.Tree
test =
  Test.group
    "Biz.Lint"
    [ Test.unit "haskell files return two Results" <| do
        results <- run Check <| Map.singleton Hs <| [Namespace ["Biz", "Lint"] Hs]
        length results @=? 2
    ]

help :: Cli.Docopt
help =
  [Cli.docopt|
all your lint are belong to us

Usage:
  lint test
  lint [--fix] [<file>...]
  lint -h, --help
|]

exit :: [Result] -> IO ()
exit results = Exit.exitWith <| (n > 0) ?: (Exit.ExitFailure n, Exit.ExitSuccess)
  where
    n = length <| filter bad results
    bad = \case
      (Warn _) -> False
      Done {status = Bad _} -> True
      _ -> False

printResult :: Result -> IO Result
printResult r = case r of
  Warn err ->
    Log.warn ["lint", err]
      >> Log.br
      >> pure r
  Done (Linter {..}) (Bad err) ->
    Log.fail ["lint", exe]
      >> Log.br
      >> (err /= "")
      ?| (putText <| Text.pack err)
      >> pure r
  Done (Linter {..}) Good ->
    Log.good ["lint", exe]
      >> Log.br
      >> pure r
  NoOp ext ->
    Log.info ["lint", "noop", show ext]
      >> pure r

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

data Mode
  = -- | Just check the files and return an exit code.
    Check
  | -- | Fix the files in place, return 0 if successful, otherwise return 1.
    Fix

data Linter = Linter
  { exe :: Text,
    -- | Arguments added when in the "check" mode
    checkArgs :: [Text],
    -- | Arguments added when in the "fix" mode
    fixArgs :: Maybe [Text],
    -- | An optional function to format the output of the linter as you want
    -- it, perhaps decoding json or something
    formatter :: Maybe (String -> String)
  }

-- deriving (Show)

ormolu :: Linter
ormolu =
  Linter
    { exe = "ormolu",
      checkArgs = ["--mode", "check", "--no-cabal"],
      fixArgs = Just ["--mode", "inplace", "--no-cabal"],
      formatter = Nothing
    }

hlint :: Linter
hlint =
  Linter
    { exe = "hlint",
      checkArgs = [],
      -- needs apply-refact >0.9.1.0, which needs ghc >9
      -- fixArgs = Just ["--refactor", "--refactor-options=-i"]
      fixArgs = Nothing,
      formatter = Nothing
    }

black :: Linter
black =
  Linter
    { exe = "black",
      checkArgs = ["--check"],
      fixArgs = Just [],
      formatter = Nothing
    }

ruff :: Linter
ruff =
  Linter
    { exe = "ruff",
      checkArgs = ["check"],
      fixArgs = Just ["check", "--fix"],
      formatter = Nothing
    }

data DeadnixOutput = DeadnixOutput
  { file :: FilePath,
    results :: [DeadnixResult]
  }
  deriving (Generic, Aeson.FromJSON)

data DeadnixResult = DeadnixResult
  { column :: Int,
    endColumn :: Int,
    line :: Int,
    message :: String
  }
  deriving (Generic, Aeson.FromJSON)

deadnix :: Linter
deadnix =
  Linter
    { exe = "deadnix",
      checkArgs = "--fail" : commonArgs,
      fixArgs = Just <| "--edit" : commonArgs,
      formatter = Just decodeDeadnixOutput
    }
  where
    commonArgs =
      [ -- "--no-underscore",
        -- "--no-lambda-pattern-names",
        "--output-format",
        "json"
      ]

decodeDeadnixOutput :: String -> String
decodeDeadnixOutput deadnixJson =
  deadnixJson |> Char8.pack |> Aeson.decodeStrict |> \case
    Nothing -> panic "could not decode deadnix output"
    Just o -> formatDeadnixOutput o
  where
    formatDeadnixOutput DeadnixOutput {..} =
      joinWith "\n" <| map formatDeadnixResult results
      where
        formatDeadnixResult DeadnixResult {..} =
          file <> ":" <> show line <> ":" <> show column <> ": " <> message

shellcheck :: Linter
shellcheck =
  Linter
    { exe = "shellcheck",
      checkArgs = [],
      fixArgs = Nothing,
      formatter = Nothing
    }

indent :: Linter
indent =
  Linter
    { exe = "indent",
      checkArgs = [],
      fixArgs = Nothing,
      formatter = Nothing
    }

data Status = Good | Bad String
  deriving (Show)

data Result
  = Done {linter :: Linter, status :: Status}
  | Warn Text
  | NoOp Namespace.Ext

run :: Mode -> Map Namespace.Ext [Namespace] -> IO [Result]
run mode nsmap = nsmap |> Map.assocs |> traverse (runOne mode) /> concat

runOne :: Mode -> (Ext, [Namespace]) -> IO [Result]
runOne mode (ext, ns's) = results +> traverse printResult
  where
    results =
      -- i would run these with mapConcurrently, but the output gets mangled. to
      -- do it right i need a queue for the results. someday.
      sequence <| case ext of
        Namespace.Hs ->
          [ lint mode ormolu ns's,
            lint mode hlint ns's
          ]
        Namespace.Py ->
          [ lint mode black ns's,
            lint mode ruff ns's
          ]
        Namespace.Sh -> [lint mode shellcheck ns's]
        Namespace.Nix -> [lint mode deadnix ns's]
        Namespace.C -> [lint mode indent ns's]
        _ -> [pure <. Warn <| "no linter for " <> show ext]

lint :: Mode -> Linter -> [Namespace] -> IO Result
lint mode linter@Linter {..} ns's =
  Log.info ["lint", exe, (tshow <| length ns's) <> " files"]
    >> Process.readProcessWithExitCode (str exe) args "" /> \case
      (Exit.ExitSuccess, _, _) ->
        Done linter Good
      (Exit.ExitFailure _, msg, _) -> case formatter of
        Nothing -> Done linter <| Bad msg
        Just fmt -> Done linter <| Bad <| fmt msg
  where
    args = case (mode, fixArgs) of
      (Fix, Just args_) ->
        map str args_ ++ map Namespace.toPath ns's
      (Fix, Nothing) ->
        map Namespace.toPath ns's
      (Check, _) ->
        map str checkArgs ++ map Namespace.toPath ns's