path: root/app/Main.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}

-- TODO Tag improvements (OR-filtering).
--
-- Currently it is not possible to filter for an issue satisfying one filter or another. We could add the following syntax allowing it:
--
-- `--filter '(@assigned aforemny) OR (@due 2023-10-4)'`
-- @topic tags

-- TODO Tag improvements (globbing).
--
-- I would like to filter `--filter '@assigned *@posteo.de'`.
-- @topic tags

-- TODO Tag improvements (priorities)
--
-- I would like anissue to support priorities when filtering. Let's for a first implementation say that priorities are represented by an integer-values `@priority` tag on an issue. The `--filter` can be extended for filtering integer-valued tags, and the following syntax:
--
-- - `--filter '@priority >1'`, `--filter '@priority <1`
-- - `--filter '@priority >=1'`, `--filter '@priority <=1`
--
-- At some later point, we can configure `high`, `medium`, `low` to mean
-- `1,2,3`, `4,5,6`, `7,8,9` respectively.
--
-- Issues having a `@priority` tag whose value is not an integer should be regarded not matching the filter.
-- @topic tags

-- TODO Tag improvements (dates).
--
-- I would like anissue to support due dates when filtering. Let's for a first implementation add the following filter syntax:
--
-- `--filter '@due 2023-10-04'` for all issues that are marked `@due 2023-10-04` or with an earlier `@due` date.
--
-- Issues having a `@due` tag whose value does not follow that date format precisely should be regarded not matching the filter.
-- @topic tags

-- TODO Add support for ammendments
--
-- The user can ammend more information to an issue which is located at
-- a different place by referencing the issue's id.  Example:
--
-- ```bash
-- #!/usr/bin/env bash
--
-- set -efu
--
-- ls -al
-- # TODO Original issue
-- #
-- # @id original-issue
--
-- ls
-- # @original-issue more information on the issue
-- ```

-- TODO Add support for other keywords
--
-- Additionally to TODO, also FIXME should start an issue.  There might
-- be more interesting keywords.

-- TODO Generate and show hash for each issue
--
-- The show hash should be generated by slugifying the issues title. Shell completion will help with the initially long issue ids. Internally, the slugified title should be added as an `@id` tag, unless an `@id` tag is present on the issue.

module Main where

import Control.Exception (Exception, catch, throw, throwIO)
import Data.Aeson qualified as A
import Data.ByteString.Lazy qualified as L
import Data.ByteString.Lazy.Char8 qualified as L8
import Data.List (intercalate)
import Data.Maybe (catMaybes)
import Data.Maybe qualified as Maybe
import Data.String qualified as String
import Data.Text qualified as T
import Issue (Issue (..))
import Issue qualified as I
import Issue.Filter (Filter)
import Issue.Filter qualified as I
import Issue.Tag qualified as I
import Options.Applicative ((<**>))
import Options.Applicative qualified as O
import Prettyprinter qualified as P
import Prettyprinter.Render.Terminal qualified as P
import System.Exit (ExitCode (ExitFailure), exitWith)
import System.FilePath qualified as F
import System.IO (hPutStrLn, stderr)
import System.Process.Typed qualified as P
import Text.Printf
import TreeGrepper.Match qualified as G
import TreeGrepper.Result qualified as G

data Options = Options
  { optCommand :: Command
  }
  deriving (Show)

data Command
  = List
      { files :: [String],
        filters :: [Filter]
      }
  | Show
      { files :: [String],
        filters :: [Filter]
      }
  deriving (Show)

commandParser :: O.Parser Command
commandParser =
  O.hsubparser
    ( O.command "list" (O.info listCommandParser (O.progDesc "List all issues"))
        <> O.command "show" (O.info showCommandParser (O.progDesc "Show details of all issues"))
    )

optionsParser :: O.Parser Options
optionsParser = Options <$> commandParser

listCommandParser :: O.Parser Command
listCommandParser = List <$> filesArg <*> I.filterOption

showCommandParser :: O.Parser Command
showCommandParser = Show <$> filesArg <*> I.filterOption

filesArg :: O.Parser [String]
filesArg = O.many (O.strArgument (O.metavar "FILE" <> O.action "file"))

main :: IO ()
main = do
  options <- O.execParser (O.info (commandParser <**> O.helper) O.idm)
  let files
        | opts@(List {}) <- options = opts.files
        | opts@(Show {}) <- options = opts.files
  filePaths <- getFiles files
  let filters
        | opts@(List {}) <- options = opts.filters
        | opts@(Show {}) <- options = opts.filters
  issues <-
    filter (I.applyFilter filters)
      . concat
      <$> catch
        ( fmap Maybe.catMaybes $
            mapM
              (\filename -> catch (fmap Just (getIssues filename)) (forgetGetIssuesExceptions))
              filePaths
        )
        ( \(InvalidTreeGrepperResult e) ->
            do
              hPutStrLn stderr e
              exitWith (ExitFailure 1)
        )
  case options of
    List {} -> listMatches issues
    Show {} -> showMatches issues

showMatches :: [Issue] -> IO ()
showMatches issues = do
  putDoc . P.vsep $
    map
      ( \issue ->
          P.vsep
            ( concat
                [ [P.annotate P.bold (P.pretty issue.title)],
                  maybe [] ((: []) . P.pretty) issue.description,
                  map
                    ( \(I.Tag k v) ->
                        P.annotate (P.colorDull P.Yellow) $
                          P.pretty ("@" `T.append` k `T.append` " " `T.append` v)
                    )
                    issue.tags
                ]
            )
      )
      issues

listMatches :: [Issue] -> IO ()
listMatches issues =
  putDoc . P.vsep $
    map
      ( \issue ->
          P.hsep
            ( concat
                [ [P.annotate P.bold (P.pretty issue.title)],
                  map
                    ( \(I.Tag k v) ->
                        P.annotate (P.colorDull P.Yellow) $
                          P.pretty ("@" `T.append` k `T.append` ":" `T.append` v)
                    )
                    issue.tags
                ]
            )
      )
      issues

putDoc :: P.Doc P.AnsiStyle -> IO ()
putDoc doc = do
  isTty <- (== 1) <$> c_isatty 1
  P.putDoc . (if isTty then id else P.unAnnotate) $ doc

foreign import ccall "unistd.h isatty" c_isatty :: Int -> IO Int

data UnknownFileExtension = UnknownFileExtension
  { extension :: String
  }
  deriving (Show)

instance Exception UnknownFileExtension

data InvalidTreeGrepperResult = InvalidTreeGrepperResult
  { error :: String
  }
  deriving (Show)

instance Exception InvalidTreeGrepperResult

forgetGetIssuesExceptions :: UnknownFileExtension -> IO (Maybe a)
forgetGetIssuesExceptions _ = pure Nothing

getIssues :: FilePath -> IO [Issue]
getIssues filename =
  let extension = F.takeExtension filename
      treeGrepperLanguage =
        -- TODO Add support for all tree-grepper supported files
        --
        -- tree-grepper supported files can be listed through `tree-grepper
        -- --languages`.
        case extension of
          ".elm" -> "elm"
          ".hs" -> "haskell"
          ".nix" -> "nix"
          ".sh" -> "sh"
          _ -> throw (UnknownFileExtension extension)
      treeGrepperQuery =
        case extension of
          ".elm" -> "([(line_comment) (block_comment)])"
          ".hs" -> "(comment)"
          ".nix" -> "(comment)"
          ".sh" -> "(comment)"
          _ -> throw (UnknownFileExtension extension)
      decode raw =
        case A.eitherDecode raw of
          Left e -> throw (InvalidTreeGrepperResult e)
          Right treeGrepperResult -> treeGrepperResult
   in catMaybes
        . map (uncurry I.fromMatch)
        . concatMap (\result -> map ((,) result) result.matches)
        . map fixTreeGrepper
        . decode
        <$> sh
          ( String.fromString
              ( printf
                  "tree-grepper --query %s %s --format json %s"
                  (quote treeGrepperLanguage)
                  (quote treeGrepperQuery)
                  (quote filename)
              )
          )

data ProcessException = ProcessException String ExitCode L.ByteString
  deriving (Show)

instance Exception ProcessException

sh :: P.ProcessConfig stdin stdoutIgnored stderr -> IO L.ByteString
sh proc = do
  (exitCode, out, err) <- P.readProcess proc
  if exitCode == P.ExitSuccess
    then pure out
    else throwIO $ ProcessException (show proc) exitCode err

fixTreeGrepper :: G.Result -> G.Result
fixTreeGrepper treeGrepperResult =
  treeGrepperResult {G.matches = G.merge treeGrepperResult.matches}

getFiles :: [String] -> IO [FilePath]
getFiles files =
  lines . L8.unpack
    <$> sh
      ( String.fromString
          ( (printf "git ls-files --cached --exclude-standard --other%s")
              ( case files of
                  [] -> ""
                  _ -> " -- " ++ intercalate " " (map quote files)
              )
          )
      )
  where

quote :: String -> String
quote s = "'" ++ escape s ++ "'"
  where
    escape [] = []
    escape ('\'' : cs) = '\\' : '\'' : escape cs
    escape (c : cs) = c : escape cs