From ea1236f2cf6d3ef4b739b2ca28f47a3bbed42295 Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Tue, 17 Oct 2023 14:14:48 +0200 Subject: refactor history --- anissue.cabal | 8 + app/Die.hs | 9 + app/Exception.hs | 38 ++++ app/Git.hs | 17 +- app/History.hs | 392 +++------------------------------------ app/History/Cache.hs | 26 +++ app/History/CommitHash.hs | 23 +++ app/History/CommitInfo.hs | 122 ++++++++++++ app/History/IssueEvent.hs | 19 ++ app/History/PartialCommitInfo.hs | 97 ++++++++++ app/Issue.hs | 75 +++++++- app/Issue/Provenance.hs | 2 +- app/Issue/Tag.hs | 2 +- app/Main.hs | 58 +++--- app/Process.hs | 12 +- 15 files changed, 484 insertions(+), 416 deletions(-) create mode 100644 app/Die.hs create mode 100644 app/Exception.hs create mode 100644 app/History/Cache.hs create mode 100644 app/History/CommitHash.hs create mode 100644 app/History/CommitInfo.hs create mode 100644 app/History/IssueEvent.hs create mode 100644 app/History/PartialCommitInfo.hs diff --git a/anissue.cabal b/anissue.cabal index f2e62cb..7b3a9e7 100644 --- a/anissue.cabal +++ b/anissue.cabal @@ -66,8 +66,15 @@ executable anissue -- Modules included in this executable, other than Main. other-modules: + Die + Exception Git History + History.Cache + History.CommitHash + History.CommitInfo + History.IssueEvent + History.PartialCommitInfo Issue Issue.Filter Issue.Provenance @@ -120,5 +127,6 @@ executable anissue OverloadedRecordDot OverloadedStrings PartialTypeSignatures + RecordWildCards TypeFamilies ViewPatterns diff --git a/app/Die.hs b/app/Die.hs new file mode 100644 index 0000000..a14f6b8 --- /dev/null +++ b/app/Die.hs @@ -0,0 +1,9 @@ +module Die (die) where + +import System.Exit (ExitCode (ExitFailure), exitWith) +import Text.Printf (printf) + +die :: String -> IO a +die s = do + printf "error: %s\n" s + exitWith (ExitFailure 1) diff --git a/app/Exception.hs b/app/Exception.hs new file mode 100644 index 0000000..83d624d --- /dev/null +++ b/app/Exception.hs @@ -0,0 +1,38 @@ +module Exception + ( AnyException (..), + InvalidTreeGrepperResult (..), + ProcessException (..), + UnknownFileExtension (..), + ) +where + +import Control.Exception +import Data.ByteString.Lazy.Char8 as LB +import System.Exit (ExitCode) + +data AnyException + = InvalidTreeGrepperResult' InvalidTreeGrepperResult + | ProcessException' ProcessException + | UnknownFileExtension' UnknownFileExtension + deriving (Show) + +instance Exception AnyException + +data InvalidTreeGrepperResult = InvalidTreeGrepperResult + { error :: String + } + deriving (Show) + +instance Exception InvalidTreeGrepperResult + +data ProcessException = ProcessException String ExitCode LB.ByteString + deriving (Show) + +instance Exception ProcessException + +data UnknownFileExtension = UnknownFileExtension + { extension :: String + } + deriving (Show) + +instance Exception UnknownFileExtension diff --git a/app/Git.hs b/app/Git.hs index 57fffdc..7891288 100644 --- a/app/Git.hs +++ b/app/Git.hs @@ -1,15 +1,24 @@ -module Git (withWorkingTree) where +module Git + ( withWorkingTree, + getCommitHashes, + ) +where import Control.Exception (finally) -import Data.Text (Text) -import Process (proc, sh_) +import Data.ByteString.Lazy.Char8 qualified as LB8 +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Process (proc, sh, sh_) import System.Directory (createDirectoryIfMissing) import System.FilePath (dropTrailingPathSeparator, takeDirectory) -- | Runs an IO-action within a working tree. -withWorkingTree :: FilePath -> Text -> IO a -> IO a +withWorkingTree :: FilePath -> T.Text -> IO a -> IO a withWorkingTree path hash action = do createDirectoryIfMissing True (takeDirectory (dropTrailingPathSeparator path)) sh_ $ proc "git worktree add --quiet --detach % %" path hash action `finally` do sh_ $ proc "git worktree remove --force %" path + +getCommitHashes :: IO [T.Text] +getCommitHashes = T.lines . T.decodeUtf8 . LB8.toStrict <$> sh "git log --format=%H" diff --git a/app/History.hs b/app/History.hs index 002ca32..efb7015 100644 --- a/app/History.hs +++ b/app/History.hs @@ -1,373 +1,31 @@ module History - ( getIssues, - listIssues, - listEvents, - IssueEvent (..), + ( getHistory, ) where -import Control.Exception (Exception, catch, handle, throw) -import Data.Aeson (eitherDecode) -import Data.Binary (Binary, decodeFileOrFail, encodeFile) -import Data.ByteString.Lazy.Char8 qualified as L8 -import Data.Function ((&)) -import Data.List (foldl') -import Data.Maybe (catMaybes, mapMaybe) -import Data.Text (Text, append, isPrefixOf, lines, pack, unpack) -import Data.Text.Encoding (decodeUtf8) -import GHC.Generics (Generic) -import Git qualified -import Issue (Issue (..), fromMatch, id) -import Issue.Filter (Filter, applyFilters) -import Issue.Sort (Sort, applySorts) -import Issue.Tag qualified as I -import Parallel (parMapM) -import Process (proc, sh) -import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory) -import System.Exit (ExitCode (ExitFailure), exitWith) -import System.FilePath (takeExtension, ()) -import System.IO.Temp (withSystemTempDirectory) -import System.Process.Typed (setWorkingDir) -import Text.Printf (printf) -import TreeGrepper.Match qualified as G -import TreeGrepper.Result qualified as G +import History.CommitHash (CommitHash) +import History.CommitInfo (CommitInfo (..), fromPartialCommitInfos, issueEvents) +import History.IssueEvent (IssueEvent (..)) +import History.PartialCommitInfo (getPartialCommitInfos) +import Issue (Issue) import Prelude hiding (id, lines) -import Prelude qualified as Prelude -listEvents :: IO [[IssueEvent]] -listEvents = do - commitHashes <- fmap reverse getCommitHashes - case commitHashes of - [] -> pure [] - hashFirst : hashesRest -> do - issuesInitial <- getIssuesCommitAll hashFirst - commitInfos <- mapM getCommitInfo hashesRest - commitInfoWorkingTree <- getCommitInfoWorkingTree [] - let eventses = getEvents hashFirst issuesInitial (commitInfos ++ [commitInfoWorkingTree]) - pure eventses - -listIssues :: [Sort] -> [Filter] -> [FilePath] -> IO [Issue] -listIssues sort filters paths = do - commitHashes <- fmap reverse getCommitHashes - case commitHashes of - [] -> - pure [] - hashFirst : hashesRest -> do - -- TODO Reduce cached data size - -- - -- Right now we are caching complete `Issue` instances, which - -- contain the full issue title and description. For a fast - -- lookup it may already be enough to only store the issue's - -- - -- \* filename - -- \* start position - -- \* end position - -- - -- With this information we can use git to quickly look up the - -- complete issue text and parse it. - -- - -- @topic caching - issuesInitial <- getIssuesCommitAll hashFirst - commitInfos <- mapM getCommitInfo hashesRest - commitInfoWorkingTree <- getCommitInfoWorkingTree paths - let eventses = getEvents hashFirst issuesInitial (commitInfos ++ [commitInfoWorkingTree]) - let issues = mapMaybe issueFromIssueEvents eventses - issuesFiltered = applyFilters filters issues - issuesSorted = applySorts sort issuesFiltered - issuesWithinPaths = - case paths of - [] -> - issuesSorted - _ -> - filter withinPaths issuesSorted - pure issuesWithinPaths - where - withinPaths issue = - any (\path -> isPrefixOf (pack path) (pack issue.file)) paths - -getCommitHashes :: IO [Text] -getCommitHashes = - fmap (lines . decodeUtf8 . L8.toStrict) $ sh "git log --format=%H" - -data IssueEvent - = IssueCreated - { hash :: Maybe Text, - issue :: Issue - } - | IssueChanged - { hash :: Maybe Text, - issue :: Issue - } - | IssueDeleted - { hash :: Maybe Text - } - deriving (Show) - -issueFromIssueEvent :: IssueEvent -> Maybe Issue -issueFromIssueEvent issueEvent = - case issueEvent of - IssueCreated {issue} -> - Just issue - IssueChanged {issue} -> - Just issue - IssueDeleted _ -> - Nothing - -data CommitInfo = CommitInfo - -- TODO Extract CommitInfo so we can change hash' -> hash - -- - -- @topic refactoring - { hash' :: Maybe Text, - filesChanged :: [FilePath], - issues :: [Issue] - } - deriving (Show, Binary, Generic) - -getCommitInfo :: Text -> IO CommitInfo -getCommitInfo hash = cached (append hash (pack ".changed")) $ \_ -> do - (issuesCommitChanged, filesChanged) <- getIssuesAndFilesCommitChanged hash - pure $ - CommitInfo - { hash' = Just hash, - filesChanged = filesChanged, - issues = issuesCommitChanged - } - -getCommitInfoWorkingTree :: [FilePath] -> IO CommitInfo -getCommitInfoWorkingTree paths = do - (issuesWorkingTreeChanged, filesChanged) <- getIssuesAndFilesWorkingTreeChanged paths - pure $ - CommitInfo - { hash' = Nothing, - filesChanged = filesChanged, - issues = issuesWorkingTreeChanged - } - -getEvents :: Text -> [Issue] -> [CommitInfo] -> [[IssueEvent]] -getEvents hashInitial issuesInitial commitInfos = - let issueEventsesInitial = - map - ( \issueInitial -> - [ IssueCreated - { hash = Just hashInitial, - issue = issueInitial - } - ] - ) - issuesInitial - addIssueEventsFromCommitInfo issueEventses commitInfo = - let issuesCreated = - map - ( \issue -> - [ IssueCreated - { hash = commitInfo.hash', - issue = issue - } - ] - ) - $ filter isNewIssue commitInfo.issues - isNewIssue issue = - all - (\issueOther -> id issueOther /= id issue) - (mapMaybe issueFromIssueEvents $ issueEventses) - addIssueChangedOrDeleted issueEventses' = - map - ( \issueEvents -> - case issueFromIssueEvent $ head issueEvents of - Nothing -> - issueEvents - Just issue -> - case filter isSameIssue commitInfo.issues of - [] -> - if any isSameFile commitInfo.filesChanged - then - IssueDeleted - { hash = commitInfo.hash' - } - : issueEvents - else issueEvents - issueCommit : _ -> - IssueChanged - { hash = commitInfo.hash', - issue = issueCommit - } - : issueEvents - where - isSameIssue issueCommit = - id issueCommit == id issue - isSameFile fileChanged = - fileChanged == issue.file - ) - issueEventses' - in issuesCreated ++ addIssueChangedOrDeleted issueEventses - in foldl' - ( addIssueEventsFromCommitInfo - ) - issueEventsesInitial - commitInfos - -issueFromIssueEvents :: [IssueEvent] -> Maybe Issue -issueFromIssueEvents issueEvents = - case issueEvents of - IssueCreated {issue} : [] -> - Just issue - IssueChanged {issue} : _ -> do - issueFirst <- issueFromIssueEvent $ head $ reverse issueEvents - pure $ - issue - { provenance = issueFirst.provenance, - internalTags = I.internalTags issue.title issueFirst.provenance - } - IssueDeleted _ : _ -> - Nothing - _ -> - Nothing - --- | Gets issues in all files which have been changed in your current --- [working --- - tree](https://git-scm.com/docs/gitglossary#Documentation/gitglossary.txt-aiddefworkingtreeaworkingtree) -getIssuesAndFilesWorkingTreeChanged :: [FilePath] -> IO ([Issue], [FilePath]) -getIssuesAndFilesWorkingTreeChanged paths = do - cwd <- getCurrentDirectory - files <- gitLsFilesModifiedIn cwd paths - issues <- concat <$> catch (getIssuesPar cwd files) dieOfInvalidTreeGrepperResult - pure (issues, files) - --- | Given the hash of a commit, get all issues in all files at the --- [tree](https://git-scm.com/docs/gitglossary#Documentation/gitglossary.txt-aiddeftreeatree) --- of this commit. -getIssuesCommitAll :: Text -> IO [Issue] -getIssuesCommitAll hash = cached (append hash (pack ".all")) $ \_ -> do - withSystemTempDirectory "history" $ \tmp -> do - let cwd = tmp unpack hash - Git.withWorkingTree cwd hash do - files <- gitLsFilesAll cwd - concat <$> catch (getIssuesPar cwd files) (dieOfInvalidTreeGrepperResult) - --- | Given the hash of a commit, get all issues in the files which have --- been changed by this commit, as well as all changed files. -getIssuesAndFilesCommitChanged :: Text -> IO ([Issue], [FilePath]) -getIssuesAndFilesCommitChanged hash = do - withSystemTempDirectory "history" $ \tmp -> do - let cwd = tmp unpack hash - Git.withWorkingTree cwd hash do - files <- gitShowChanged cwd - issues <- concat <$> catch (getIssuesPar cwd files) (dieOfInvalidTreeGrepperResult) - pure (issues, files) - -gitLsFilesAll :: FilePath -> IO [FilePath] -gitLsFilesAll cwd = - Prelude.lines . L8.unpack - <$> sh ("git ls-files --cached --exclude-standard --other" & setWorkingDir cwd) - -gitShowChanged :: FilePath -> IO [FilePath] -gitShowChanged cwd = - Prelude.lines . L8.unpack - <$> sh ("git show -p --name-only --format=''" & setWorkingDir cwd) - -gitLsFilesModifiedIn :: FilePath -> [FilePath] -> IO [FilePath] -gitLsFilesModifiedIn cwd paths = - Prelude.lines . L8.unpack - <$> sh - ( proc "git ls-files --modified %" ("--" : paths) - & setWorkingDir cwd - ) - --- | Get all issues in the given directory and files. Runs --- parallelized. -getIssuesPar :: FilePath -> [FilePath] -> IO [[Issue]] -getIssuesPar cwd files = - parMapM (handle forgetGetIssuesExceptions . getIssues cwd) files - -data UnknownFileExtension = UnknownFileExtension - { extension :: String - } - deriving (Show) - -instance Exception UnknownFileExtension - -forgetGetIssuesExceptions :: UnknownFileExtension -> IO [a] -forgetGetIssuesExceptions _ = pure [] - -data InvalidTreeGrepperResult = InvalidTreeGrepperResult - { error :: String - } - deriving (Show) - -instance Exception InvalidTreeGrepperResult - -dieOfInvalidTreeGrepperResult :: InvalidTreeGrepperResult -> IO a -dieOfInvalidTreeGrepperResult (InvalidTreeGrepperResult e) = - die e - --- | Get all issues in the given directory and file. -getIssues :: FilePath -> FilePath -> IO [Issue] -getIssues cwd filename = do - let extension = 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 eitherDecode raw of - Left e -> throw (InvalidTreeGrepperResult e) - Right treeGrepperResult -> treeGrepperResult - - matches <- - concatMap (\result -> map ((,) result) result.matches) - . map fixTreeGrepper - . decode - <$> sh - ( proc - "tree-grepper --query % % --format json %" - (treeGrepperLanguage :: String) - (treeGrepperQuery :: String) - filename - & setWorkingDir cwd - ) - - catMaybes <$> mapM (uncurry (fromMatch cwd)) matches - -fixTreeGrepper :: G.Result -> G.Result -fixTreeGrepper treeGrepperResult = - treeGrepperResult {G.matches = G.merge treeGrepperResult.matches} - -cached :: Binary a => Text -> (Text -> IO a) -> IO a -cached hash func = do - -- FIXME Cache inside Git root - -- - -- The cache location should not be dependant on the current directory, but - -- should be placed alongside the `.git` directory. - cwd <- getCurrentDirectory - createDirectoryIfMissing True (cwd ++ "/.anissue") - let file = (cwd ++ "/.anissue/" ++ unpack hash) - doesFileExist file >>= \case - True -> - decodeFileOrFail file >>= \case - Left _ -> generate file - Right blob -> pure blob - False -> generate file - where - generate file = do - blob <- func hash - encodeFile file blob - pure blob - -die :: String -> IO a -die s = do - printf "error: %s\n" s - exitWith (ExitFailure 1) +-- TODO Reduce cached data size +-- +-- Right now we are caching complete `Issue` instances, which +-- contain the full issue title and description. For a fast +-- lookup it may already be enough to only store the issue's +-- +-- \* filename +-- \* start position +-- \* end position +-- +-- With this information we can use git to quickly look up the +-- complete issue text and parse it. +-- +-- @topic caching + +getHistory :: IO ([Issue], [(CommitHash, [IssueEvent])]) +getHistory = do + commitInfos <- fromPartialCommitInfos <$> getPartialCommitInfos + pure ((last commitInfos).issues, issueEvents commitInfos) diff --git a/app/History/Cache.hs b/app/History/Cache.hs new file mode 100644 index 0000000..af40a84 --- /dev/null +++ b/app/History/Cache.hs @@ -0,0 +1,26 @@ +module History.Cache (cached) where + +import Data.Binary (Binary, decodeFileOrFail, encodeFile) +import Data.Text qualified as T +import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory) + +cached :: Binary a => T.Text -> (T.Text -> IO a) -> IO a +cached hash func = do + -- FIXME Cache inside Git root + -- + -- The cache location should not be dependant on the current directory, but + -- should be placed alongside the `.git` directory. + cwd <- getCurrentDirectory + createDirectoryIfMissing True (cwd ++ "/.anissue") + let file = (cwd ++ "/.anissue/" ++ T.unpack hash) + doesFileExist file >>= \case + True -> + decodeFileOrFail file >>= \case + Left _ -> generate file + Right blob -> pure blob + False -> generate file + where + generate file = do + blob <- func hash + encodeFile file blob + pure blob diff --git a/app/History/CommitHash.hs b/app/History/CommitHash.hs new file mode 100644 index 0000000..3fcbb90 --- /dev/null +++ b/app/History/CommitHash.hs @@ -0,0 +1,23 @@ +module History.CommitHash + ( CommitHash (..), + toShortText, + toText, + ) +where + +import Data.Binary (Binary) +import Data.Text qualified as T +import GHC.Generics (Generic) + +data CommitHash + = WorkingTree + | Commit T.Text + deriving (Show, Binary, Generic) + +toShortText :: CommitHash -> T.Text +toShortText WorkingTree = "" +toShortText (Commit hash) = T.take 7 hash + +toText :: CommitHash -> T.Text +toText WorkingTree = "" +toText (Commit hash) = hash diff --git a/app/History/CommitInfo.hs b/app/History/CommitInfo.hs new file mode 100644 index 0000000..8461b8e --- /dev/null +++ b/app/History/CommitInfo.hs @@ -0,0 +1,122 @@ +module History.CommitInfo + ( CommitInfo (..), + fromPartialCommitInfos, + issueEvents, + diffCommitInfos, + ) +where + +import Data.Binary (Binary) +import Data.Function (on) +import Data.List (deleteFirstsBy, find) +import Data.Maybe (catMaybes, isJust) +import GHC.Generics (Generic) +import History.CommitHash (CommitHash) +import History.IssueEvent (IssueEvent (..)) +import History.PartialCommitInfo (PartialCommitInfo (..)) +import Issue (Issue (..), id) +import Issue.Tag qualified as I +import TreeGrepper.Match (Position (..)) +import Prelude hiding (id) + +data CommitInfo = CommitInfo + { hash :: CommitHash, + filesChanged :: [FilePath], + issues :: [Issue] + } + deriving (Show, Binary, Generic) + +fromPartialCommitInfos :: [PartialCommitInfo] -> [CommitInfo] +fromPartialCommitInfos [] = [] +fromPartialCommitInfos (partialCommitInfo : partialCommitInfos) = + scanl propagate (assume partialCommitInfo) partialCommitInfos + where + assume :: PartialCommitInfo -> CommitInfo + assume (PartialCommitInfo {..}) = CommitInfo {..} + + propagate :: CommitInfo -> PartialCommitInfo -> CommitInfo + propagate oldInfo newInfo@(PartialCommitInfo {..}) = + CommitInfo + { issues = + catMaybes $ + mergeListsBy + eq + ( \old new -> + Just + new + { provenance = old.provenance, + internalTags = I.internalTags new.title old.provenance + } + ) + ( \old -> + if elemBy eq old newInfo.issues + || not (old.file `elem` newInfo.filesChanged) + then Just old + else Nothing + ) + (\new -> Just new) + oldInfo.issues + newInfo.issues, + .. + } + + eq = (==) `on` id + +issueEvents :: [CommitInfo] -> [(CommitHash, [IssueEvent])] +issueEvents xs = zip (map (.hash) xs') (zipWith diffCommitInfos xs xs') + where + xs' = tail xs + +diffCommitInfos :: CommitInfo -> CommitInfo -> [IssueEvent] +diffCommitInfos oldInfo newInfo = + concat + [ [IssueCreated newHash issue | issue <- deleteFirstsBy eq newIssues oldIssues], + [ IssueChanged newHash (last issues) + | issues <- intersectBy' eq newIssues oldIssues, + not (null [(x, y) | x <- issues, y <- issues, clear x /= clear y]) + ], + [IssueDeleted newHash issue | issue <- deleteFirstsBy eq oldIssues newIssues] + ] + where + newHash = newInfo.hash + newIssues = newInfo.issues + oldIssues = oldInfo.issues + + -- TODO Fix issue comparison + -- + -- Because issues carry `provenance` and `internalTags`, issues compare + -- unequally when we want them to be equal. + clear i = + i + { provenance = Nothing, + internalTags = [], + start = Position 0 0, + end = Position 0 0, + file = "" + } + + eq = (==) `on` id + +mergeListsBy :: (a -> a -> Bool) -> (a -> a -> b) -> (a -> b) -> (a -> b) -> [a] -> [a] -> [b] +mergeListsBy eq onBoth onLeft onRight lefts rights = + concat + [ [ maybe (onLeft left) (onBoth left) right + | left <- lefts, + right <- + let rights' = filter (eq left) rights + in if null rights' then [Nothing] else (map Just rights') + ], + [ onRight right + | right <- rights, + not (elemBy eq right lefts) + ] + ] + +-- | A variant of `Data.List.intersectBy` that retuns the witnesses of the +-- intersection. +intersectBy' :: (a -> a -> Bool) -> [a] -> [a] -> [[a]] +intersectBy' eq xs ys = filter (not . null) (map (\x -> x : filter (eq x) ys) xs) + +-- | A variant of `elem` that uses a custom comparison function. +elemBy :: (a -> a -> Bool) -> a -> [a] -> Bool +elemBy eq x xs = isJust $ find (eq x) xs diff --git a/app/History/IssueEvent.hs b/app/History/IssueEvent.hs new file mode 100644 index 0000000..88886dd --- /dev/null +++ b/app/History/IssueEvent.hs @@ -0,0 +1,19 @@ +module History.IssueEvent (IssueEvent (..)) where + +import History.CommitHash (CommitHash) +import Issue (Issue) + +data IssueEvent + = IssueCreated + { hash :: CommitHash, + issue :: Issue + } + | IssueChanged + { hash :: CommitHash, + issue :: Issue + } + | IssueDeleted + { hash :: CommitHash, + issue :: Issue + } + deriving (Show) diff --git a/app/History/PartialCommitInfo.hs b/app/History/PartialCommitInfo.hs new file mode 100644 index 0000000..fb53fbf --- /dev/null +++ b/app/History/PartialCommitInfo.hs @@ -0,0 +1,97 @@ +module History.PartialCommitInfo + ( PartialCommitInfo (..), + getPartialCommitInfos, + ) +where + +import Control.Exception (catch) +import Data.Binary (Binary) +import Data.ByteString.Lazy.Char8 qualified as LB8 +import Data.Function ((&)) +import Data.Text qualified as T +import Die (die) +import Exception qualified as E +import GHC.Generics (Generic) +import Git qualified +import History.Cache (cached) +import History.CommitHash (CommitHash (..)) +import Issue (Issue, getIssuesPar) +import Process (proc, sh) +import System.Directory (getCurrentDirectory) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Process.Typed (setWorkingDir) + +-- | `PartialCommitInfo` records the complete issues ONLY in files that have +-- been changed in the commit. +data PartialCommitInfo = PartialCommitInfo + { hash :: CommitHash, + filesChanged :: [FilePath], + issues :: [Issue] + } + deriving (Show, Binary, Generic) + +getPartialCommitInfos :: IO [PartialCommitInfo] +getPartialCommitInfos = do + -- TODO Revise `getCommitHashes` + -- + -- - Should throw if no commits. + -- - Should always be reversed? + commitHashes <- reverse <$> Git.getCommitHashes + mapM getCommitInfoOf (map Commit commitHashes ++ [WorkingTree]) + +getCommitInfoOf :: CommitHash -> IO PartialCommitInfo +getCommitInfoOf WorkingTree = do + (issuesWorkingTreeChanged, filesChanged) <- getIssuesAndFilesWorkingTreeChanged [] + pure $ + PartialCommitInfo + { hash = WorkingTree, + filesChanged = filesChanged, + issues = issuesWorkingTreeChanged + } +getCommitInfoOf (Commit hash) = cached (hash <> (T.pack ".changed")) $ \_ -> do + (issuesCommitChanged, filesChanged) <- getIssuesAndFilesCommitChanged hash + pure $ + PartialCommitInfo + { hash = Commit hash, + filesChanged = filesChanged, + issues = issuesCommitChanged + } + +-- | Given the hash of a commit, get all issues in the files which have +-- been changed by this commit, as well as all changed files. +getIssuesAndFilesCommitChanged :: T.Text -> IO ([Issue], [FilePath]) +getIssuesAndFilesCommitChanged hash = do + withSystemTempDirectory "history" $ \tmp -> do + let cwd = tmp T.unpack hash + Git.withWorkingTree cwd hash do + files <- gitShowChanged cwd + issues <- concat <$> catch (getIssuesPar cwd files) dieOfInvalidTreeGrepperResult + pure (issues, files) + +dieOfInvalidTreeGrepperResult :: E.InvalidTreeGrepperResult -> IO a +dieOfInvalidTreeGrepperResult (E.InvalidTreeGrepperResult e) = + die e + +-- | Gets issues in all files which have been changed in your current +-- [working +-- - tree](https://git-scm.com/docs/gitglossary#Documentation/gitglossary.txt-aiddefworkingtreeaworkingtree) +getIssuesAndFilesWorkingTreeChanged :: [FilePath] -> IO ([Issue], [FilePath]) +getIssuesAndFilesWorkingTreeChanged paths = do + cwd <- getCurrentDirectory + files <- gitLsFilesModifiedIn cwd paths + issues <- concat <$> catch (getIssuesPar cwd files) dieOfInvalidTreeGrepperResult + pure (issues, files) + +gitShowChanged :: FilePath -> IO [FilePath] +gitShowChanged cwd = + Prelude.lines . LB8.unpack + <$> sh ("git show -p --name-only --format=''" & setWorkingDir cwd) + +gitLsFilesModifiedIn :: FilePath -> [FilePath] -> IO [FilePath] +gitLsFilesModifiedIn cwd paths = + Prelude.lines . LB8.unpack + <$> sh + ( proc "git ls-files --modified %" ("--" : paths) + & setWorkingDir cwd + ) diff --git a/app/Issue.hs b/app/Issue.hs index efb61b7..a4e2d73 100644 --- a/app/Issue.hs +++ b/app/Issue.hs @@ -1,14 +1,30 @@ -module Issue (Issue (..), Provenance (..), fromMatch, id) where +module Issue + ( Issue (..), + Provenance (..), + fromMatch, + id, + getIssuesPar, + ) +where +import Control.Exception (handle, throw) +import Data.Aeson (eitherDecode) import Data.Binary (Binary) +import Data.Function ((&)) import Data.List (find, foldl') +import Data.Maybe (catMaybes) import Data.Text (Text) import Data.Text qualified as T +import Exception qualified as E import GHC.Generics (Generic) import Issue.Provenance (Provenance (..), provenanceFromHEAD) import Issue.Tag (Tag (..)) import Issue.Tag qualified as I import Issue.Text qualified as I +import Parallel (parMapM) +import Process (proc, sh) +import System.FilePath (takeExtension) +import System.Process.Typed (setWorkingDir) import TreeGrepper.Match (Match (..)) import TreeGrepper.Match qualified as G import TreeGrepper.Result (Result (..)) @@ -25,7 +41,7 @@ data Issue = Issue tags :: [Tag], internalTags :: [Tag] } - deriving (Show, Binary, Generic) + deriving (Show, Binary, Generic, Eq) id :: Issue -> Maybe String id issue = @@ -70,3 +86,58 @@ stripIssueMarkers text = stripIssueMarker :: Text -> Text -> Text stripIssueMarker text marker = maybe text T.stripStart (T.stripPrefix marker text) + +-- | Get all issues in the given directory and files. Runs +-- parallelized. +getIssuesPar :: FilePath -> [FilePath] -> IO [[Issue]] +getIssuesPar cwd files = + parMapM (handle forgetGetIssuesExceptions . getIssues cwd) files + +-- | Get all issues in the given directory and file. +getIssues :: FilePath -> FilePath -> IO [Issue] +getIssues cwd filename = do + let extension = 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 (E.UnknownFileExtension extension) + treeGrepperQuery = + case extension of + ".elm" -> "([(line_comment) (block_comment)])" + ".hs" -> "(comment)" + ".nix" -> "(comment)" + ".sh" -> "(comment)" + _ -> throw (E.UnknownFileExtension extension) + decode raw = + case eitherDecode raw of + Left e -> throw (E.InvalidTreeGrepperResult e) + Right treeGrepperResult -> treeGrepperResult + + matches <- + concatMap (\result -> map ((,) result) result.matches) + . map fixTreeGrepper + . decode + <$> sh + ( proc + "tree-grepper --query % % --format json %" + (treeGrepperLanguage :: String) + (treeGrepperQuery :: String) + filename + & setWorkingDir cwd + ) + + catMaybes <$> mapM (uncurry (fromMatch cwd)) matches + +fixTreeGrepper :: G.Result -> G.Result +fixTreeGrepper treeGrepperResult = + treeGrepperResult {G.matches = G.merge treeGrepperResult.matches} + +forgetGetIssuesExceptions :: E.UnknownFileExtension -> IO [a] +forgetGetIssuesExceptions _ = pure [] diff --git a/app/Issue/Provenance.hs b/app/Issue/Provenance.hs index 7cf4faa..f3d382c 100644 --- a/app/Issue/Provenance.hs +++ b/app/Issue/Provenance.hs @@ -25,7 +25,7 @@ data Provenance = Provenance authorEmail :: Text, authorName :: Text } - deriving (Show, Generic, Binary) + deriving (Show, Generic, Binary, Eq) -- XXX These are taken from `Data.Binary.Orphans` [1]. I cannot get importing -- the instance from the package to work.. so we use `-fno-warn-orphans` here. diff --git a/app/Issue/Tag.hs b/app/Issue/Tag.hs index 85636b5..42a371d 100644 --- a/app/Issue/Tag.hs +++ b/app/Issue/Tag.hs @@ -15,7 +15,7 @@ import Data.Time.Clock (UTCTime (utctDay)) import GHC.Generics (Generic) import Issue.Provenance (Provenance (..)) -data Tag = Tag Text (Maybe Text) deriving (Show, Generic, Binary) +data Tag = Tag Text (Maybe Text) deriving (Show, Generic, Binary, Eq) tagKey :: Tag -> Text tagKey (Tag k _) = k diff --git a/app/Main.hs b/app/Main.hs index a7901bd..3bb60e2 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -447,18 +447,20 @@ module Main where import Control.Applicative ((<|>)) import Data.Function ((&)) -import Data.List (find) +import Data.List (find, isPrefixOf) import Data.Maybe (catMaybes) import Data.Text 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 (IssueEvent (..), listEvents, listIssues) +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) +import Issue.Filter (Filter, applyFilters) import Issue.Filter qualified as I -import Issue.Sort (Sort) +import Issue.Sort (Sort, applySorts) import Issue.Sort qualified as I import Options.Applicative ((<**>)) import Options.Applicative qualified as O @@ -586,9 +588,7 @@ idArg = O.strArgument ( O.metavar "ID" <> O.completer - ( O.listIOCompleter $ - catMaybes . map I.id <$> listIssues [] [] [] - ) + (O.listIOCompleter $ catMaybes . map I.id . fst <$> getHistory) ) die :: String -> IO a @@ -600,7 +600,8 @@ main :: IO () main = do O.execParser (O.info (options <**> O.helper) O.idm) >>= \case Options {colorize, noPager, width, command = List {sort, filters, files}} -> do - issues <- listIssues sort filters files + 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 -> @@ -633,34 +634,25 @@ main = do ) issues Options {colorize, noPager, width, command = Log} -> do - -- TODO Reconcile log - -- - -- When viewing the log I am confused by - -- - -- (1) lots of sequential commits "changing" the same one issue, but no - -- others, - -- (2) having unknown hashes interleaved - -- - -- I would assume changes to be less frequent, or, if no changes are - -- considered changes, the log output sorted by hashes (and not - -- commits?). I would expect only the first commit hash to be unknown. - -- - -- Thoughts? :-) - es <- concat <$> listEvents + (_, ess') <- getHistory putDoc colorize noPager width . P.vsep $ - map - ( \e -> - let shortHash = P.annotate (P.color P.Yellow) . P.pretty $ maybe "UNKNOWN" (T.take 7) e.hash - 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 {} -> shortHash <+> kwd "deleted" + 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' ) - es + (reverse ess') Options {colorize, width, command = Show {id}} -> do - issues <- listIssues [] [] [] + issues <- fst <$> getHistory case find ((==) (Just id) . I.id) issues of Nothing -> die (printf "no issue with id `%s'\n" id) Just issue -> do diff --git a/app/Process.hs b/app/Process.hs index 9ce5e46..2b3eaf6 100644 --- a/app/Process.hs +++ b/app/Process.hs @@ -11,34 +11,30 @@ module Process ) where -import Control.Exception (Exception, throwIO) +import Control.Exception (throwIO) import Data.ByteString.Lazy.Char8 qualified as LB import Data.List (intercalate) import Data.String (fromString) import Data.Text qualified as T import Data.Text.Lazy qualified as LT import Data.Text.Lazy.Encoding qualified as LT +import Exception qualified as E import System.Exit (ExitCode (ExitSuccess)) import System.Process.Typed (ProcessConfig, StreamSpec, StreamType (STInput), byteStringInput, readProcess, readProcessStderr) -data ProcessException = ProcessException String ExitCode LB.ByteString - deriving (Show) - -instance Exception ProcessException - sh :: ProcessConfig stdin stdoutIgnored stderr -> IO LB.ByteString sh processConfig = do (exitCode, out, err) <- readProcess processConfig if exitCode == ExitSuccess then pure out - else throwIO $ ProcessException (show processConfig) exitCode err + else throwIO $ E.ProcessException (show processConfig) exitCode err sh_ :: ProcessConfig stdin stdoutIgnored stderr -> IO () sh_ processConfig = do (exitCode, err) <- readProcessStderr processConfig if exitCode == ExitSuccess then pure () - else throwIO $ ProcessException (show processConfig) exitCode err + else throwIO $ E.ProcessException (show processConfig) exitCode err class Quotable a where quote :: a -> String -- cgit v1.2.3