diff options
| -rw-r--r-- | app/Exception.hs | 7 | ||||
| -rw-r--r-- | app/History/CommitInfo.hs | 11 | ||||
| -rw-r--r-- | app/Issue.hs | 17 | ||||
| -rw-r--r-- | app/Issue/Provenance.hs | 47 | ||||
| -rw-r--r-- | app/Issue/Tag.hs | 4 | ||||
| -rw-r--r-- | app/Main.hs | 17 |
6 files changed, 72 insertions, 31 deletions
diff --git a/app/Exception.hs b/app/Exception.hs index 83d624d..ddaef5a 100644 --- a/app/Exception.hs +++ b/app/Exception.hs @@ -1,6 +1,7 @@ module Exception ( AnyException (..), InvalidTreeGrepperResult (..), + NoCommits (..), ProcessException (..), UnknownFileExtension (..), ) @@ -12,6 +13,7 @@ import System.Exit (ExitCode) data AnyException = InvalidTreeGrepperResult' InvalidTreeGrepperResult + | NoCommits' NoCommits | ProcessException' ProcessException | UnknownFileExtension' UnknownFileExtension deriving (Show) @@ -25,6 +27,11 @@ data InvalidTreeGrepperResult = InvalidTreeGrepperResult instance Exception InvalidTreeGrepperResult +data NoCommits = NoCommits + deriving (Show) + +instance Exception NoCommits + data ProcessException = ProcessException String ExitCode LB.ByteString deriving (Show) diff --git a/app/History/CommitInfo.hs b/app/History/CommitInfo.hs index 8461b8e..b42e1ba 100644 --- a/app/History/CommitInfo.hs +++ b/app/History/CommitInfo.hs @@ -15,6 +15,7 @@ import History.CommitHash (CommitHash) import History.IssueEvent (IssueEvent (..)) import History.PartialCommitInfo (PartialCommitInfo (..)) import Issue (Issue (..), id) +import Issue.Provenance qualified as I import Issue.Tag qualified as I import TreeGrepper.Match (Position (..)) import Prelude hiding (id) @@ -44,7 +45,15 @@ fromPartialCommitInfos (partialCommitInfo : partialCommitInfos) = ( \old new -> Just new - { provenance = old.provenance, + { provenance = + (\oldProvenance newProvenance -> + ( I.Provenance + { first = oldProvenance.first, + last = newProvenance.last + } + ) + ) + <$> old.provenance <*> new.provenance, internalTags = I.internalTags new.title old.provenance } ) diff --git a/app/Issue.hs b/app/Issue.hs index a4e2d73..451b897 100644 --- a/app/Issue.hs +++ b/app/Issue.hs @@ -17,7 +17,7 @@ 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.Provenance (Provenance (..), commitFromHEAD) import Issue.Tag (Tag (..)) import Issue.Tag qualified as I import Issue.Text qualified as I @@ -35,6 +35,9 @@ data Issue = Issue { title :: Text, description :: Maybe Text, file :: String, + -- TODO Make provenance obligatory + -- + -- I cannot think of instances where an issue exists without a provenance.. provenance :: Maybe Provenance, start :: G.Position, end :: G.Position, @@ -48,9 +51,15 @@ id issue = (\(Tag _ v) -> T.unpack <$> v) =<< find (\(Tag k _) -> k == "id") (issue.tags ++ issue.internalTags) +-- TODO Refactor non-issues +-- +-- This does not return an issue, as provenance is not computed over its +-- history. Maybe this should return a different type, or be internal to +-- `History`? Also, `internalTags` suffer. fromMatch :: FilePath -> G.Result -> G.Match -> IO (Maybe Issue) fromMatch cwd result match = do - provenance <- provenanceFromHEAD cwd + commit <- commitFromHEAD cwd + let provenance = Provenance commit commit pure ( if any (\marker -> T.isPrefixOf marker title') issueMarkers @@ -60,11 +69,11 @@ fromMatch cwd result match = do { title = title, description = description, file = result.file, - provenance = provenance, + provenance = Just provenance, start = match.start, end = match.end, tags = maybe [] I.extractTags description, - internalTags = I.internalTags title provenance + internalTags = I.internalTags title (Just provenance) } else Nothing ) diff --git a/app/Issue/Provenance.hs b/app/Issue/Provenance.hs index f3d382c..4d69472 100644 --- a/app/Issue/Provenance.hs +++ b/app/Issue/Provenance.hs @@ -2,28 +2,45 @@ module Issue.Provenance ( Provenance (..), - provenanceFromHEAD, + Commit (..), + Author (..), + commitFromHEAD, ) where +import Control.Exception (throwIO) import Data.Binary (Binary, Put, get, put) import Data.ByteString.Lazy.Char8 (toStrict) import Data.Fixed (Pico) import Data.Function ((&)) -import Data.Text (Text, lines, splitOn, unpack) +import Data.Text (lines, splitOn, unpack) +import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8) import Data.Time.Calendar (Day (..), toModifiedJulianDay) import Data.Time.Clock (DiffTime, UTCTime (..), picosecondsToDiffTime) +import Exception qualified as E import GHC.Generics (Generic) import Process (sh) import System.Process.Typed (setWorkingDir) import Prelude hiding (lines) data Provenance = Provenance - { firstCommit :: Text, + { first :: Commit, + last :: Commit + } + deriving (Show, Generic, Binary, Eq) + +data Commit = Commit + { -- TODO `T.Text` -> `CommitHash` + hash :: T.Text, date :: UTCTime, - authorEmail :: Text, - authorName :: Text + author :: Author + } + deriving (Show, Generic, Binary, Eq) + +data Author = Author + { name :: T.Text, + email :: T.Text } deriving (Show, Generic, Binary, Eq) @@ -43,22 +60,20 @@ instance Binary DiffTime where get = fmap picosecondsToDiffTime get put = (put :: Pico -> Put) . realToFrac -provenanceFromHEAD :: FilePath -> IO (Maybe Provenance) -provenanceFromHEAD cwd = do +commitFromHEAD :: FilePath -> IO Commit +commitFromHEAD cwd = do rawProvenance <- fmap (splitOn "\NUL" . head . lines . decodeUtf8 . toStrict) $ sh $ "git show --quiet --format='%H%x00%ai%x00%ae%x00%an'" & setWorkingDir cwd - pure $ case rawProvenance of - firstCommit' : rawDate : authorEmail : authorName : _ -> + case rawProvenance of + hash : rawDate : authorEmail : authorName : _ -> let date = read (unpack rawDate) - in Just - Provenance - { firstCommit = firstCommit', + in pure + Commit + { hash = hash, date = date, - authorEmail = authorEmail, - authorName = authorName + author = Author authorName authorEmail } - _ -> - Nothing + _ -> throwIO E.NoCommits diff --git a/app/Issue/Tag.hs b/app/Issue/Tag.hs index 42a371d..2947ec9 100644 --- a/app/Issue/Tag.hs +++ b/app/Issue/Tag.hs @@ -13,7 +13,7 @@ import Data.Text (Text, pack) import Data.Text qualified as T import Data.Time.Clock (UTCTime (utctDay)) import GHC.Generics (Generic) -import Issue.Provenance (Provenance (..)) +import Issue.Provenance (Provenance (..), Commit(..)) data Tag = Tag Text (Maybe Text) deriving (Show, Generic, Binary, Eq) @@ -46,7 +46,7 @@ internalTags title provenance' = maybe [] ( \provenance -> - [ Tag "createdAt" $ Just $ pack $ show $ utctDay provenance.date + [ Tag "createdAt" $ Just $ pack $ show $ utctDay provenance.first.date ] ) provenance' diff --git a/app/Main.hs b/app/Main.hs index 3bb60e2..28a32bb 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -447,6 +447,7 @@ module Main where import Control.Applicative ((<|>)) import Data.Function ((&)) +import Issue.Provenance qualified as I import Data.List (find, isPrefixOf) import Data.Maybe (catMaybes) import Data.Text qualified as T @@ -610,13 +611,13 @@ main = do keyword "in" <+> value (T.pack issue.file <> ":" <> T.pack (show issue.start.row)) commit = fromProvenanceDef (keyword "via" <+> value (T.pack "HEAD")) $ - \I.Provenance {firstCommit} -> keyword "via" <+> value (T.take 7 firstCommit) + \I.Provenance {first} -> keyword "via" <+> value (T.take 7 first.hash) author = fromProvenance $ - \I.Provenance {authorName, authorEmail} -> - ( keyword "by" <+> value (authorName <> " <" <> authorEmail <> ">") + \I.Provenance {first} -> + ( keyword "by" <+> value (first.author.name <> " <" <> first.author.email <> ">") ) date' = fromProvenance $ - \I.Provenance {date} -> keyword "on" <+> value (show (utctDay date)) + \I.Provenance {first} -> keyword "on" <+> value (show (utctDay first.date)) fromProvenanceDef def = flip (maybe def) issue.provenance fromProvenance = flip fmap issue.provenance @@ -671,13 +672,13 @@ main = do "HEAD" Just provenance -> "\nvia " - ++ T.unpack provenance.firstCommit + ++ T.unpack provenance.first.hash ++ "\nby " - ++ T.unpack provenance.authorName + ++ T.unpack provenance.first.author.name ++ " <" - ++ T.unpack provenance.authorEmail + ++ T.unpack provenance.first.author.email ++ ">\nat " - ++ show provenance.date + ++ show provenance.first.date ) ++ "\n\n" sh_ |