path: root/app/Main.hs

-- 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 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
--
-- edited
-- ```

-- TODO Add options to show command to display source code around the issue
--
-- The `show` command should have the command line arguments
-- `--after/-A`, `--before/-B` and `--context/-C` which take an integer
-- n and change the output to contain n lines after, before or around
-- the issue.
--
-- @topic show
-- @topic options
--
-- COMMENT Do we expect the code BEFORE an issue to be ever relevant?
--
-- COMMENT Hm, this would make it possible for users to use anissue in
-- that way at least.  I guess most people would assume a comment to go
-- before (or for a short comment at the end) the relecant line(s), so
-- maybe an `--after/-A` option would suffice.  Not sure what's best
-- here to be honest. =)
--
-- COMMENT I don't mind the `--before|-B` option. I was just wondering out
-- loud, also related to whether we want to extract some closed part of the
-- AST, seeing that we already have tree sitter, instead of showing context.
--
-- But I don't have a good proposal for that myself. It is not my intention to
-- block on this issue.

-- TODO Expose all command line options as environment variables
--
-- It should be possible to provide a default for any command line
-- argument via an environment variable.  The name of the variable
-- should be all upper case and prefixed with `ANISSUE_`, e.g. the
-- default value for the command line option `--internal-tags` should be
-- settable via `ANISSUE_INTERNAL_TAGS`.
--
-- @topic options
-- @topic settings
--
-- COMMENT Can/ should this be made a feature of optparse-applicative, which we
-- could fork? Like, can this work transparently if we fork
-- optparse-applicative?
--
-- COMMENT Hm, this would only apply to options and flags, but not sub
-- commands, I guess.  I would say, we could first start by just
-- manually adding these env variables and see if we run into
-- options/flags, where a env variable does not make sense.  But then,
-- this would be an optional feature in the library, as well, i guess?
-- :D
--
-- COMMENT I could imagine it not too difficult adding a `fromEnv` modifier
-- into `O.Parser`. In any case, this does not have to block on that, as,
-- should we decide to do that, we can always migrate to it later.

-- TODO Add a subcommand which appends the generated ids to the issue in the sourcecode
--
-- Given the following issue
--
-- ```
-- # TODO Some title
-- #
-- # Some description
-- ```
--
-- After running `anissue lint`, the issue will be changed to
--
-- ```
-- # TODO Some title
-- #
-- # Some description
-- #
-- # @id some-title
-- ```
--
-- @topic ids
--
-- COMMENT Can you elaborate on why this would be useful? I am expecting us to
-- do some renaming detection regarding provenance. After that, will it be
-- useful still?
--
-- COMMENT I think, I mostly find this useful for ammendments, as I then
-- neither would have to think about what the generated id was, nor
-- would I have to come up with an id.  And if we would decide for
-- randomized (but easily typeable) generated ids, this would be useful,
-- I believe.
--
-- COMMENT Assuming the we append **the title** as the ID, I don't see much
-- point of this. Maybe better editor integration that auto-completes `@<<ID>>`
-- would be more appropriate?
--
-- I am sympathetic to random identifiers, cf.
-- @should-automatically-generated-ids-be-random, as long as they are an
-- additional mechanisam (so that we can ditch them, should they not work out).

-- FIXME Exclude tags in code blocks
--
-- Tags which appear in markdown code blocks should not be considered
-- tags.
--
-- @topic tags

-- TODO Only separate generated tags with a blank line when description does not end with tags
--
-- An issue like
--
-- ```
-- # TODO Some title
-- #
-- # @id some-title
-- ```
--
-- Should be rendered as
--
-- ```
-- # TODO Some title
--
-- @id some-title
-- @file the-file.sh
-- @row 42
-- ```
--
-- @topic tags

-- QUESTION Should automatically generated ids be random?
--
-- Right now default id of an issue is the slugification of it's title.
-- Once we have a command to automatically append this id to the issue
-- within the source code, users might feel tempted to change the id
-- after they have adjusted the title. This then would break the
-- provenance of the issue.  If the generated id was something like
-- `tooth-cherry-switch`, it would be just a random string and noone
-- would feel the need to change it.
--
-- I imagine a workflow where I add issues in the source code.  And
-- before commiting, I run `anissue lint` to generate ids for all new
-- issues.
--
-- @topic ids
-- @scheduled 2023-10-30
--
-- COMMENT I am not sure we want to automatically append `@id`s to the issue
-- description. We probably want to append `@pastId` to an issue if we notice a
-- change in the title. I feel users are not as likely change that.
--
-- That being said, I am up for experimenting with random IDs *alongside* the
-- current design. Maybe we could add a `@uuid` tag automatically that is
-- generated from the issues first `@id`, and append that?
--
-- COMMENT I think I like the idea of adding an id, once we see a change in the
-- title.  I'm not sure though, when in the workflow this would happen.
-- I think the id generation topic needs some syncronous discussion. :D
--
-- COMMENT ACK

-- TODO Dependencies between issues
--
-- The user should be able to specify that an issue is blocked by
-- a different issue by adding `@blocker id-of-blocking-issue`.
--
-- When running `anissue list --show-dependencies`, the output should
-- render a list of trees deduced from these blocker-relations. E.g.
--
-- ```
-- Issue A
-- ├ Issue A1 (blocked by A)
-- │ ├ Issue A11 (blocked by A1)
-- ├─┴ Issue A3A11 (blocked by A and A1)
-- └ Issue A2B1 (blocked by A and B)
-- Issue B
-- └ Issue A2B1 (blocked by A and B)
-- Issue C
-- ```
--
-- The items should be ordered with the most blocking issues at the top.
--
-- @topic dependencies

-- TODO Add fulltext search
--
-- Additional to `--filter` it should be possible to search for issues
-- using `--search 'some query'` using a search-engine like full text
-- search.
--
-- To make this fast, we could use a package like
-- <https://hackage.haskell.org/package/full-text-search> and make sure
-- to persist the index in a local cache.
--
-- @topic search

-- TODO Display issue type in list and show views
--
-- Depending on the type of issue (TODO, FIXME, ...) there should be
-- either a prefix in the list view (e.g. 🏗️, 🐞, ...), or the list
-- should be grouped by the type.
--
-- COMMENT I imagine emojis might be off-putting to some potential users. I
-- would like a configuration option to disable emojis and display the marker
-- instead.
--
-- I am fine with having emojis by default. However, seeing that markers are
-- extendable, maybe we should make it an opt-in configuration in the first
-- place?
--
-- COMMENT Yes, thinking about this again, putting the written marker
-- instead, might be better.  So sth like.
--
-- ```
-- FIXME    Issue A
-- FIXME    Issue B
-- TODO     Story A
-- QUESTION Question A
-- FIXME    Issue C
-- ```
--
-- We could still additionally color code them.
--
-- COMMENT I propose adding the issue marker as an internal @marker tag. There
-- can be several such tags if several markers are specified (and we want to
-- allow that). The first marker should have priority in case we have to pick
-- one.

-- TODO Add option to group issue list
--
-- When running `anissue list` with the `--group-by` option, the output
-- will be grouped.  E.g. running `anissue list --group-by topic` would
-- produce
--
-- ```
-- Issue D
-- Issue E
--
-- @topic tags  (2 issues)
-- Issue A
-- Issue B @topic ids
--
-- @topic ids  (2 issues)
-- Issue B @topic tags
-- Issue C
-- ```
--
-- Other possible grouping options could be
--
-- type
-- : the issue type, i.e. `TODO`, `FIXME`, `QUESTION`, etc.
--
-- priority
-- : the priority, groups should be sorted with the highest priority
-- first
--
-- author
-- : the person which created the issue
--
-- editor
-- : the person who updated the issue last
--
-- @topic options
--
-- COMMENT For consistency, I would like the option to use `--group-by @topic`.
-- Arbitrary tag grouping seems sufficient for this, assuming we add the
-- respective *internal tags*.
--
-- COMMENT Sounds good!

-- TODO Support issue comments
-- Currently, comments do not get picked up in issue descriptions; see the
-- issue below.
--
-- I would like to parse comments (much like issues), and associate them with
-- the preceding issue.
--
-- `anissue show` should then show all comments below the current output.

-- TODO Add options to specify ordering of issues
--
-- When running `anissue list` with the `--order-by` option, the list
-- should be ordered accordingly.  Possible values could be
--
-- creation
-- : the time when the issue was created
--
-- update
-- : the time when the issue was updated last
--
-- title
-- : lexicographically by title
--
-- priority
-- : by priority
--
-- Additionally using `--reversed`, the order will be reversed.
--
-- @topic options
--
-- COMMENT `anissue list` now supports `--sort` which allows sorting by tags.
-- To facilitate the first use-case, sorting by creation, an internal tag
-- `@createdAt` has been added. Reversing is possible, ie. `--sort
-- '-@createdAt'`
--
-- Supposing we want to go this direction, I feel like all of the use-cases can
-- be implemented using internal tags and adding support for a couple of data
-- types within String-valued tags. (Sorting by `@createdAt` currently only
-- works because date-based ordering coincides with string-based ordering on
-- the used `YYYY-MM-DD` format.)
--
-- What do you think?
--
-- PS. Nothing prevents us later to extend functionality by special cases,
-- should we dislike an internal `@title` tag.
--
-- COMMENT I like this approach! :)

-- TODO Add command for (re)generating the cache
--
-- When running `anissue cache generate`, we will only generated the
-- issue cache, starting from the initial commit.  This will not
-- re-generate already existing cache entries.  To delete the old cache
-- first, one has to add `--clean`.
--
-- By adding `--first-commit <commit-hash>` the cache will only
-- generated starting at the specified commit.
--
-- By adding `--full` the cache will be generated for **all** commits in
-- the repository.
--
-- When running `anissue cache clean`, the local cache will be deleted.
--
-- @topic options
-- @topic cache
-- @scheduled 2023-10-30
--
-- COMMENT What is the point of this command? Can't caches be handled
-- transparently to the user?
--
-- COMMENT Hm, I think I don't exactly know, what you mean by
-- transparently. ':)  So cache invalidation would be like how e.g. elm
-- does it with the elm-stuff folder?
--
-- The idea for the cache generation command could be e.g. used in
-- environment setup scripts.  And then the first-commit option would
-- make it possible to use very old repostories without a too long
-- initial delay.
--
-- COMMENT The caching works *transparently* for the user if the user is not
-- aware of the cache at all. If there are cache commands (or options), then it
-- is not transparent.
--
-- I get that we want to limit provenance generation somewhat, and that will
-- have to be solved in an intransparent manner.. but I am not fully
-- understanding the proposal.
--
-- Maybe you could walk me through it in our next session?

-- TODO Add global option for specifying first considered commit
--
-- Every command offers the option `--first-commit <commit-hash>`, which
-- tells anissue to only consider commits stargin with the provided
-- commit.  The default is the first commit HEAD eventually points to;
-- this will also happen when the provided commit is not in the history
-- of HEAD.
--
-- @topic options
-- @topic cache

-- TODO Add format option (Text, JSON, ...)
--
-- Add an option `--format` to the list and show commands which adjust
-- the output format:
--
-- text
-- : this is the default
--
-- json
-- : render all information as json so that it can be used, e.g. by
-- other tools
--
-- @topic rendering
-- @topic options

-- TODO Add command for listing all topics
--
-- Running `anissue topics` should list all topics including the amount of
-- issues tagged with them.  By default the list should be ordered with the
-- topics first which have the most issues.
--
-- COMMENT Maybe `anissue tags @topic` could serve that purpose? I imagine
-- `anissue tags` (without a tag given) to list all tags.
--
-- \*Rationale: I would like to push for concepts out of anissue for as long as
-- feasible . Currently, there is no notion of "topics".*

-- TODO Add HTTP server
--
-- When running `anissue server`, an HTTP server should be started,
-- which serves a JSON-API as well as a HTML-frontend for the current
-- directory.
--
-- The HTML frontend should display the output of `anissue list` where
-- each item links to a separate page containing the infos of `anissue
-- show`.
--
-- The JSON-Api offers endpoints `GET /<commit>/` which returns `anissue
-- list` as `GET /<commit>/<issue-id>/` which returns `anissue show`.
-- All command line arguments are exposed via query parameters.

module Main where

import Control.Applicative ((<|>))
import Data.Function ((&))
import Data.List (find, isPrefixOf)
import Data.Maybe (catMaybes)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.IO qualified as LT
import Data.Time.Clock (UTCTime (utctDay))
import History (getHistory)
import History.CommitHash qualified as CH
import History.IssueEvent (IssueEvent (..))
import Issue (Issue (..))
import Issue qualified as I
import Issue.Filter (Filter, applyFilters)
import Issue.Filter qualified as I
import Issue.Provenance qualified as I
import Issue.Sort (Sort, applySorts)
import Issue.Sort qualified as I
import Options.Applicative ((<**>))
import Options.Applicative qualified as O
import Prettyprinter ((<+>))
import Prettyprinter qualified as P
import Prettyprinter.Render.Terminal qualified as P
import Process (proc, sh_, textInput)
import Settings (Settings (..), readSettings)
import System.Console.Terminal.Size qualified as Terminal
import System.Exit (ExitCode (ExitFailure), exitWith)
import System.IO (hClose, hFlush)
import System.IO.Temp (withSystemTempFile)
import System.Process.Typed qualified as P
import Text.Printf
import TreeGrepper.Match qualified as G
import Prelude hiding (id)

data Options = Options
  { command :: Command,
    internalTags :: Bool,
    colorize :: Color,
    noPager :: Bool,
    width :: Maybe Int
  }
  deriving (Show)

data Color
  = Always
  | Auto
  | Never
  deriving (Show, Eq)

options :: O.Parser Options
options =
  Options
    <$> cmd
    <*> internalTagsFlag
    <*> colorOption
    <*> noPagerFlag
    <*> widthOption

internalTagsFlag :: O.Parser Bool
internalTagsFlag =
  O.switch
    ( O.long "internal-tags"
        <> O.help "Whether to display internal tags."
    )

colorOption :: O.Parser Color
colorOption =
  O.option
    (O.maybeReader parse)
    ( O.long "color"
        <> O.short 'c'
        <> O.help "Wether to colorize output. (Default: auto)"
        <> O.value Auto
    )
  where
    parse "auto" = pure Auto
    parse "always" = pure Always
    parse "never" = pure Never
    parse _ = Nothing

noPagerFlag :: O.Parser Bool
noPagerFlag =
  O.switch
    ( O.long "no-pager"
        <> O.short 'P'
        <> O.help "Don't pipe long output to $PAGER."
    )

widthOption :: O.Parser (Maybe Int)
widthOption =
  O.optional
    ( O.option
        O.auto
        ( O.long "width"
            <> O.short 'w'
            <> O.metavar "INT"
            <> O.help "Wheather to insert line breaks after at most that many characters."
        )
    )

data Command
  = List
      { files :: [String],
        filters :: [Filter],
        sort :: [Sort]
      }
  | Log
  | Show
      { id :: String,
        edit :: Bool
      }
  deriving (Show)

cmd :: O.Parser Command
cmd =
  O.hsubparser . mconcat $
    [ O.command "list" . O.info listCmd $
        O.progDesc "List all issues",
      O.command "log" . O.info logCmd $
        O.progDesc "Show a log of all issues",
      O.command "show" . O.info showCmd $
        O.progDesc "Show details of all issues"
    ]

listCmd :: O.Parser Command
listCmd =
  List
    <$> filesArg
    <*> I.filterArg
    <*> I.sortArg

logCmd :: O.Parser Command
logCmd =
  pure Log

showCmd :: O.Parser Command
showCmd =
  Show
    <$> idArg
    <*> editFlag

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

idArg :: O.Parser String
idArg =
  O.strArgument
    ( O.metavar "ID"
        <> O.completer
          (O.listIOCompleter $ catMaybes . map I.id . fst <$> getHistory)
    )

editFlag :: O.Parser Bool
editFlag =
  O.switch
    ( O.long "edit"
        <> O.help "Edit issue in $EDITOR."
    )

die :: String -> IO a
die s = do
  printf "error: %s\n" s
  exitWith (ExitFailure 1)

main :: IO ()
main = do
  settings <- readSettings
  O.execParser (O.info (options <**> O.helper) O.idm) >>= \case
    Options {colorize, noPager, width, command = List {sort, filters, files}} -> do
      let withinPath issue = if null files then True else any (\file -> file `isPrefixOf` issue.file) files
      issues <- applySorts sort . applyFilters filters . filter withinPath . fst <$> getHistory
      putDoc colorize noPager width . P.vsep $
        map
          ( \issue ->
              let title = P.annotate P.bold $ P.pretty issue.title
                  fileAndRow =
                    keyword "in"
                      <+> value (T.pack issue.file <> ":" <> T.pack (show issue.start.row))
                  commit = fromProvenanceDef (keyword "via" <+> value (T.pack "HEAD")) $
                    \I.Provenance {first} -> keyword "via" <+> value (T.take 7 first.hash)
                  author = fromProvenance $
                    \I.Provenance {first} ->
                      ( keyword "by" <+> value (first.author.name <> " <" <> first.author.email <> ">")
                      )
                  createdAt = fromProvenance $
                    \I.Provenance {first} -> keyword "on" <+> value (show (utctDay first.date))
                  modifiedAt = fromProvenance $
                    \I.Provenance {last = last'} -> keyword "modified" <+> value (show (utctDay last'.date))

                  fromProvenanceDef def = flip (maybe def) issue.provenance
                  fromProvenance = flip fmap issue.provenance
                  keyword :: T.Text -> P.Doc P.AnsiStyle
                  keyword = P.annotate (P.colorDull P.Green) . P.pretty
                  value :: P.Pretty a => a -> P.Doc P.AnsiStyle
                  value = P.annotate (P.color P.Green) . P.pretty
               in P.nest 4 . P.vsep . catMaybes $
                    [ Just title,
                      Just fileAndRow,
                      Just commit,
                      author,
                      createdAt,
                      modifiedAt
                    ]
          )
          issues
    Options {colorize, noPager, width, command = Log} -> do
      (_, ess') <- getHistory
      putDoc colorize noPager width . P.vsep $
        concatMap
          ( \(hash, es') ->
              let shortHash = P.annotate (P.color P.Yellow) . P.pretty $ CH.toShortText hash
               in map
                    ( \e ->
                        let kwd = P.annotate (P.color P.Green) . P.pretty . T.pack
                            title issue = P.annotate (P.color P.Blue) . P.annotate P.bold $ P.pretty issue.title
                         in case e of
                              IssueCreated {issue} -> shortHash <+> kwd "created" <+> title issue
                              IssueChanged {issue} -> shortHash <+> kwd "changed" <+> title issue
                              IssueDeleted {issue} -> shortHash <+> kwd "deleted" <+> title issue
                    )
                    es'
          )
          (reverse ess')
    Options {colorize, width, command = Show {id, edit}} -> do
      issues <- fst <$> getHistory
      issue <-
        case find ((==) (Just id) . I.id) issues of
          Nothing -> die (printf "no issue with id `%s'\n" id)
          Just issue -> pure issue
      let s =
            -- TODO Hardcoded issue marker.
            ("TODO " <> LT.fromStrict issue.title)
              <> maybe "" (("\n\n" <>) . LT.fromStrict) issue.description
      if edit
        then do
          withSystemTempFile (printf "%s.md" id) $ \fp h -> do
            LT.hPutStr h s
            hFlush h
            hClose h
            sh_ (proc "${EDITOR-vi} -- %" fp)
            replaceText issue =<< T.readFile fp
        else do
          -- TODO Make `show` page-able
          --
          -- We have to set `noPager` unconditionally to `True` for now, as not
          -- all output is `mdcat` compatible.
          putDoc colorize True width $
            P.annotate (P.color P.Green) $
              P.pretty $
                issue.file
                  ++ ":"
                  ++ show issue.start.row
                  ++ ( case issue.provenance of
                         Nothing ->
                           "HEAD"
                         Just provenance ->
                           "\nvia "
                             ++ T.unpack provenance.first.hash
                             ++ "\nby "
                             ++ T.unpack provenance.first.author.name
                             ++ " <"
                             ++ T.unpack provenance.first.author.email
                             ++ ">\nat "
                             ++ show provenance.first.date
                     )
                  ++ "\n\n"
          sh_
            ( ( case width of
                  Nothing -> "mdcat --local"
                  Just width' -> proc "mdcat --columns % --local" width'
              )
                & P.setStdin (textInput s)
            )
          putDoc colorize True width $
            P.pretty $
              "\n@file "
                ++ issue.file
                ++ "\n@row "
                ++ show issue.start.row
                ++ "\n"

-- TODO Move `replaceText` to `Issue`

-- TODO `replaceFile` hardcodes comment
replaceText :: Issue -> T.Text -> IO ()
replaceText issue s' = T.writeFile issue.file . replace (indent (comment s')) =<< T.readFile issue.file
  where
    comment = T.intercalate "\n" . map T.strip . map ("-- " <>) . T.lines
    indent = T.intercalate "\n" . mapButFirst (T.replicate (issue.start.column - 1) " " <>) . T.lines
    replace s t = before <> s <> after
      where
        t' = T.lines t
        before = T.intercalate "\n" (mapLast (T.take (issue.start.column - 1)) (take issue.start.row t'))
        after = T.unlines (mapFirst (T.drop issue.end.column) (drop (issue.end.row - 1) t'))
    mapFirst _ [] = []
    mapFirst f (x : xs) = f x : xs
    mapLast _ [] = []
    mapLast f [x] = [f x]
    mapLast f (x : xs) = x : mapLast f xs
    mapButFirst _ [] = []
    mapButFirst f (x : xs) = x : map f xs

putDoc :: Color -> Bool -> Maybe Int -> P.Doc P.AnsiStyle -> IO ()
putDoc colorize noPager width doc = do
  isTty <- (== 1) <$> c_isatty 1
  term <- Terminal.size
  let s =
        P.renderLazy
          $ P.layoutSmart
            P.defaultLayoutOptions
              { P.layoutPageWidth =
                  maybe
                    P.Unbounded
                    (\n -> P.AvailablePerLine n 1)
                    (width <|> (Terminal.width <$> term))
              }
          $ ( if colorize == Always || (colorize == Auto && isTty)
                then (\x -> x)
                else P.unAnnotate
            )
          $ doc
  if not noPager && maybe False (length (LT.lines s) >) (Terminal.height <$> term)
    then
      sh_
        ( "${PAGER-less}"
            & P.shell
            & P.setStdin (textInput s)
        )
    else LT.putStr s

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