aboutsummaryrefslogtreecommitdiffstats
path: root/app
diff options
context:
space:
mode:
Diffstat (limited to 'app')
-rw-r--r--app/History.hs82
-rw-r--r--app/IssueEvent.hs43
-rw-r--r--app/Main.hs9
-rw-r--r--app/Render.hs11
4 files changed, 79 insertions, 66 deletions
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' =
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 18:30:54 +0000