path: root/app/Main.hs

{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}

-- 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 Only one issue per comment block
--
-- Only the first TODO/FIXME inside a comment block should be considered
-- as the start of an issue.
--
-- TODO Add support for other keywords
--
-- Additionally to TODO, also FIXME should start an issue.  There might
-- be more interesting keywords.

-- TODO Add tags
--
-- Users can add tags inside issue title and description.  Tags are slugs
-- and start with @
--
-- @assigned aforemny

-- TODO Add filter by tags
--
-- Users can filter issues for tags with the option -t/--tag @tag.
--
-- @assigned kirchner@posteo.de

-- TODO Generate and show hash for each issue

module Main where

import Control.Exception (Exception, catch, throw)
import Data.Aeson qualified as A
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as LB
import Data.ByteString.Lazy.Char8 qualified as LB8
import Data.List as L
import Data.Maybe qualified as Maybe
import Data.Ord as O
import Data.String qualified as String
import GHC.Generics (Generic)
import Options.Applicative ((<**>))
import Options.Applicative qualified as O
import System.Exit (ExitCode (ExitFailure), exitWith)
import System.FilePath as F
import System.IO (hPutStrLn, stderr)
import System.Process.Typed qualified as P

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

data Command
  = List
  | Show
  deriving (Show)

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

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

listCommandParser :: O.Parser Command
listCommandParser =
  pure List

showCommandParser :: O.Parser Command
showCommandParser =
  pure Show

main :: IO ()
main = do
  options <- O.execParser (O.info (commandParser <**> O.helper) O.idm)
  files <- getFiles
  issues <-
    catch
      ( fmap Maybe.catMaybes $
          mapM
            (\filename -> catch (fmap Just (getIssues filename)) (forgetGetIssuesExceptions))
            files
      )
      ( \(InvalidTreeGrepperResult error) ->
          do
            hPutStrLn stderr error
            exitWith (ExitFailure 1)
      )
  let issuesWithMarker = issues
      issuesWithTags = issuesWithMarker
      issuesFilteredByTags = issuesWithTags
  case options of
    List -> mapM_ listMatches $ concat issues
    Show -> mapM_ showMatches $ concat issues

showMatches :: TreeGrepperResult -> IO ()
showMatches treeGrepperResult =
  mapM_ (putStrLn . (.text)) $ treeGrepperResult.matches

listMatches :: TreeGrepperResult -> IO ()
listMatches treeGrepperResult =
  mapM_ (putStrLn . (.text)) $ treeGrepperResult.matches

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

instance Exception UnknownFileExtension

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

instance Exception InvalidTreeGrepperResult

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

data Issue = Issue {}

data TreeGrepperResult = TreeGrepperResult
  { file :: String,
    file_type :: String,
    matches :: [Match]
  }
  deriving (Show, Generic)

instance A.FromJSON TreeGrepperResult

data Match = Match
  { kind :: String,
    name :: String,
    text :: String,
    start :: Position,
    end :: Position
  }
  deriving (Show, Generic)

instance A.FromJSON Match

data Position = Position
  { row :: Int,
    column :: Int
  }
  deriving (Show, Generic)

instance A.FromJSON Position

getIssues :: String -> IO [TreeGrepperResult]
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 error ->
            throw (InvalidTreeGrepperResult error)
          Right treeGrepperResult ->
            treeGrepperResult
   in fmap (map fixTreeGrepper) $
        fmap (decode . snd) $
          P.readProcessStdout
            ( String.fromString
                ( "tree-grepper --query '"
                    ++ treeGrepperLanguage
                    ++ "' '"
                    ++ treeGrepperQuery
                    ++ "' --format json '"
                    ++ filename
                    ++ "'"
                )
            )

fixTreeGrepper :: TreeGrepperResult -> TreeGrepperResult
fixTreeGrepper treeGrepperResult =
  treeGrepperResult {matches = mergeMatches treeGrepperResult.matches}
  where
    mergeMatches matches =
      Maybe.catMaybes
        [ subs ms
          | ms <- L.groupBy eq matches
        ]
    eq m n = m.end.row + 1 <= n.start.row
    subs [] = Nothing
    subs (mss@(m : _)) =
      Just
        ( m
            { start = start mss,
              end = end mss,
              text = unlines (map (.text) mss)
            }
        )
    start ms = minimumBy (O.comparing loc) (map (.start) ms)
    end ms = maximumBy (O.comparing loc) (map (.end) ms)
    loc x = (x.row, x.column)

getFiles :: IO [String]
getFiles =
  fmap (lines . LB8.unpack . snd) $
    P.readProcessStdout "git ls-files --cached --exclude-standard --other"