From 4426863f07901f626a537f2f0bb717b1bd1b0f6d Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Tue, 12 Dec 2023 15:32:47 +0100 Subject: chore: compute patches only when displayed --- app/History.hs | 82 +++++++++++++++++++++++-------------------------------- app/IssueEvent.hs | 43 +++++++++++++++++++++++------ app/Main.hs | 9 ------ app/Render.hs | 11 ++++++++ 4 files changed, 79 insertions(+), 66 deletions(-) (limited to 'app') diff --git a/app/History.hs b/app/History.hs index 57cb53c..31651bd 100644 --- a/app/History.hs +++ b/app/History.hs @@ -12,15 +12,12 @@ import Control.Arrow (first) import Control.Exception (catch, handle, try) import Data.Binary (Binary) import Data.ByteString.Lazy qualified as LB -import Data.Function (on, (&)) +import Data.Function (on) import Data.List.NonEmpty qualified as N import Data.Map qualified as M import Data.Maybe (catMaybes) import Data.Text qualified as T import Data.Text.Encoding qualified as T -import Data.Text.IO qualified as T -import Data.Text.Lazy qualified as LT -import Data.Text.Lazy.Encoding qualified as LT import Die (die) import Exception qualified as E import GHC.Generics (Generic) @@ -32,13 +29,9 @@ import Issue.Parser qualified as I import Issue.Tag qualified as I import Issue.Text qualified as I import IssueEvent (IssueEvent (..)) -import Parallel (parMapM, parSequence) -import Patch qualified as A +import Parallel (parMapM) import Process (proc, sh) import Render qualified as P -import System.FilePath (()) -import System.IO.Temp (withSystemTempDirectory) -import System.Process.Typed (setWorkingDir) import Tuple () -- TODO Reduce cached data size @@ -71,11 +64,11 @@ getHistoryOf :: CommitHash -> IO History getHistoryOf commitHash = cachedMaybe (C.toText commitHash) do maybeParentCommitHash <- getParentCommitHashOf commitHash case maybeParentCommitHash of - Just parentCommitHash -> do - parentHistory <- getHistoryOf parentCommitHash - scramble <- getScrambleOf commitHash - propagate commitHash parentHistory scramble - Nothing -> unsafeAssume commitHash =<< getScrambleOf commitHash + Just parentCommitHash -> + propagate commitHash + <$> (getHistoryOf parentCommitHash) + <*> (getScrambleOf commitHash) + Nothing -> unsafeAssume commitHash <$> getScrambleOf commitHash getParentCommitHashOf :: CommitHash -> IO (Maybe CommitHash) getParentCommitHashOf commitHash = @@ -148,11 +141,13 @@ fromComment commitHash comment = do where (commentStyle, rawText) = G.uncomment comment.language comment.text -propagate :: CommitHash -> History -> Scramble -> IO History -propagate commitHash oldHistory scramble = do +propagate :: CommitHash -> History -> Scramble -> History +propagate commitHash oldHistory scramble = let issues = propagateIssues oldHistory.issues scramble - issueEvents <- propagateIssueEvents oldHistory.issueEvents oldHistory.issues commitHash issues - pure $ History {..} + in History + { issueEvents = propagateIssueEvents oldHistory.issueEvents oldHistory.issues commitHash issues, + .. + } propagateIssues :: M.Map T.Text I.Issue -> Scramble -> M.Map T.Text I.Issue propagateIssues oldIssues scramble = @@ -183,43 +178,34 @@ propagateIssues oldIssues scramble = oldIssues scramble.issues -propagateIssueEvents :: [IssueEvent] -> M.Map T.Text I.Issue -> CommitHash -> M.Map T.Text I.Issue -> IO [IssueEvent] +propagateIssueEvents :: [IssueEvent] -> M.Map T.Text I.Issue -> CommitHash -> M.Map T.Text I.Issue -> [IssueEvent] propagateIssueEvents oldIssueEvents oldIssues commitHash issues = - fmap (oldIssueEvents ++) $ newIssueEvents oldIssues commitHash issues + oldIssueEvents ++ newIssueEvents oldIssues commitHash issues -newIssueEvents :: M.Map T.Text I.Issue -> CommitHash -> M.Map T.Text I.Issue -> IO [IssueEvent] +newIssueEvents :: M.Map T.Text I.Issue -> CommitHash -> M.Map T.Text I.Issue -> [IssueEvent] newIssueEvents oldIssues' commitHash issues' = - parSequence $ - concat - [ [ IssueCreated commitHash issue <$> patchCreated issue - | issue <- M.elems (issues `M.difference` oldIssues) - ], - [ IssueChanged commitHash oldIssue newIssue <$> patchChanged oldIssue newIssue - | (newIssue, oldIssue) <- M.elems (M.intersectionWith (,) issues oldIssues), - newIssue `neq` oldIssue - ], - [ IssueDeleted commitHash issue {I.closed = True} <$> patchDeleted issue - | issue <- M.elems (oldIssues `M.difference` issues) - ] + concat + [ [ IssueCreated commitHash issue + | issue <- M.elems (issues `M.difference` oldIssues) + ], + [ IssueChanged commitHash oldIssue newIssue + | (newIssue, oldIssue) <- M.elems (M.intersectionWith (,) issues oldIssues), + newIssue `neq` oldIssue + ], + [ IssueDeleted commitHash issue {I.closed = True} + | issue <- M.elems (oldIssues `M.difference` issues) ] + ] where issues = M.filter (not . (.closed)) issues' oldIssues = M.filter (not . (.closed)) oldIssues' - patchCreated new = diff "" new.rawText - patchChanged old new = diff old.rawText new.rawText - patchDeleted old = diff old.rawText "" - - diff old new = withSystemTempDirectory "diff" $ \tmp -> do - let cwd = tmp - T.writeFile (tmp "old") old - T.writeFile (tmp "new") new - A.parse . LT.toStrict . LT.decodeUtf8 <$> sh ("git diff --no-index -- old new || :" & setWorkingDir cwd) - neq = (/=) `on` (.rawText) -unsafeAssume :: CommitHash -> Scramble -> IO History -unsafeAssume commitHash scramble = do - let issues = scramble.issues - issueEvents <- propagateIssueEvents [] M.empty commitHash issues - pure $ History {..} +unsafeAssume :: CommitHash -> Scramble -> History +unsafeAssume commitHash scramble = + History + { issues = scramble.issues, + issueEvents = propagateIssueEvents [] M.empty commitHash scramble.issues, + .. + } diff --git a/app/IssueEvent.hs b/app/IssueEvent.hs index a7a190a..c82dba5 100644 --- a/app/IssueEvent.hs +++ b/app/IssueEvent.hs @@ -1,33 +1,58 @@ -module IssueEvent (IssueEvent (..)) where +{-# OPTIONS_GHC -fno-warn-orphans #-} -import Data.Binary (Binary) +module IssueEvent + ( IssueEvent (..), + ) +where + +import Data.Binary (Binary (..)) +import Data.Function ((&)) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Text.Lazy qualified as LT +import Data.Text.Lazy.Encoding qualified as LT import GHC.Generics (Generic) +import GHC.Records (HasField (..)) import Git.CommitHash (CommitHash) -import Issue (Issue) +import Issue (Issue (..)) import Issue.Render qualified as I import Patch (Patch) +import Patch qualified as A +import Process (sh) import Render ((<<<)) import Render qualified as P +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Process.Typed (setWorkingDir) data IssueEvent = IssueCreated { hash :: CommitHash, - issue :: Issue, - patch :: Patch + issue :: Issue } | IssueChanged { hash :: CommitHash, oldIssue :: Issue, - issue :: Issue, - patch :: Patch + issue :: Issue } | IssueDeleted { hash :: CommitHash, - issue :: Issue, - patch :: Patch + issue :: Issue } deriving (Show, Generic, Binary) +instance HasField "patch" IssueEvent (IO Patch) where + getField (IssueCreated {..}) = diff "" issue.rawText + getField (IssueChanged {..}) = diff oldIssue.rawText issue.rawText + getField (IssueDeleted {..}) = diff issue.rawText "" + +diff :: T.Text -> T.Text -> IO A.Patch +diff old new = withSystemTempDirectory "diff" $ \tmp -> do + let cwd = tmp + T.writeFile (tmp "old") old + T.writeFile (tmp "new") new + A.parse . LT.toStrict . LT.decodeUtf8 <$> sh ("git diff --no-index -- old new || :" & setWorkingDir cwd) + instance P.Render IssueEvent where render = P.render . P.Detailed diff --git a/app/Main.hs b/app/Main.hs index ea9077b..6ccc29a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,12 +1,3 @@ --- TODO Compute patches only when demanded --- --- Currently, `IssueEvents` contain patches of the relevant issues. These --- patches are computed upfront, and also when not needed (ie. if not shown). --- Additionally, there are cached. --- --- I think it would be sufficient to compute patches on-the-fly, ie. when --- requested to be shown. - -- TODO Compute history from the top -- -- Currently we are computing the history from the bottom (ie. earliest commit diff --git a/app/Render.hs b/app/Render.hs index 964581f..6cb0373 100644 --- a/app/Render.hs +++ b/app/Render.hs @@ -35,6 +35,7 @@ import Data.Text qualified as T import Data.Time.Calendar (Day) import Prettyprinter import Prettyprinter.Render.Terminal +import System.IO.Unsafe (unsafePerformIO) -- | The render class is a superclass of `Pretty`. It exists to facilitate -- reporting styles (see below), as well as decomposing aggregate entities into composable parts (for instance `IssueTitle`, `IssueTags` of `Issue`). @@ -55,6 +56,16 @@ instance Render String instance Render Day where render = render . show +-- TODO Resolve `performUnsafeIO` +-- +-- We want `Renderable a => IO a` in our data structures so that we can defer potentially expensive computation until it is actually required to be rendered. +-- +-- We should be able to eliminate `unsafePerformIO` by lifting `render` to `a -> IO (Doc AnsiStyle)`. +-- +-- @backlog +instance Render a => Render (IO a) where + render = render . unsafePerformIO + -- | The `(<<<)` combinator concatenates renderables. It takes care of inserting spaces between non-empty renderables automatically, obsoleting prettyprinter's `(<+>)` and `(<>)`. (<<<) :: (Render a, Render b) => a -> b -> Doc AnsiStyle (<<<) a' b' = -- cgit v1.2.3