diff options
Diffstat (limited to 'app/History.hs')
| -rw-r--r-- | app/History.hs | 392 |
1 files changed, 25 insertions, 367 deletions
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) |