diff options
| -rw-r--r-- | anissue.cabal | 1 | ||||
| -rw-r--r-- | app/Issue.hs | 55 | ||||
| -rw-r--r-- | app/Issue/Provenance.hs | 64 |
3 files changed, 68 insertions, 52 deletions
diff --git a/anissue.cabal b/anissue.cabal index fd051cc..f3ebd02 100644 --- a/anissue.cabal +++ b/anissue.cabal @@ -69,6 +69,7 @@ executable anissue History Issue Issue.Filter + Issue.Provenance Issue.Tag Issue.Text Parallel diff --git a/app/Issue.hs b/app/Issue.hs index f7895af..75e700d 100644 --- a/app/Issue.hs +++ b/app/Issue.hs @@ -1,22 +1,14 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} module Issue (Issue (..), Provenance (..), fromMatch, id) where -import Data.Binary (Binary, Put, get, put) -import Data.ByteString.Lazy (toStrict) -import Data.Fixed (Pico) -import Data.Function ((&)) +import Data.Binary (Binary) import Data.List (find, foldl') import Data.Text (Text) 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 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 Process (sh) -import System.Process.Typed (setWorkingDir) import TreeGrepper.Match (Match (..)) import TreeGrepper.Match qualified as G import TreeGrepper.Result (Result (..)) @@ -35,30 +27,6 @@ data Issue = Issue } deriving (Show, Binary, Generic) -data Provenance = Provenance - { firstCommit :: Text, - date :: UTCTime, - authorEmail :: Text, - authorName :: Text - } - deriving (Show, Generic, Binary) - --- 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. --- --- [1] https://hackage.haskell.org/package/binary-orphans-0.1.5.1/docs/src/Data-Binary-Orphans.html#line-132 -instance Binary UTCTime where - get = UTCTime <$> get <*> get - put (UTCTime d dt) = put d >> put dt - -instance Binary Day where - get = fmap ModifiedJulianDay get - put = put . toModifiedJulianDay - -instance Binary DiffTime where - get = fmap picosecondsToDiffTime get - put = (put :: Pico -> Put) . realToFrac - id :: Issue -> Maybe String id issue = (\(Tag _ v) -> T.unpack v) @@ -68,24 +36,7 @@ id issue = fromMatch :: FilePath -> G.Result -> G.Match -> IO (Maybe Issue) fromMatch cwd result match = do - rawProvenance <- - fmap (T.splitOn "\NUL" . head . T.lines . decodeUtf8 . toStrict) $ - sh $ - "git show --quiet --format='%H%x00%ai%x00%ae%x00%an'" - & setWorkingDir cwd - let provenance = - case rawProvenance of - firstCommit' : rawDate : authorEmail : authorName : _ -> - let date = read (T.unpack rawDate) - in Just - Provenance - { firstCommit = firstCommit', - date = date, - authorEmail = authorEmail, - authorName = authorName - } - _ -> - Nothing + provenance <- provenanceFromHEAD cwd pure ( if any (\marker -> T.isPrefixOf marker title') issueMarkers diff --git a/app/Issue/Provenance.hs b/app/Issue/Provenance.hs new file mode 100644 index 0000000..7cf4faa --- /dev/null +++ b/app/Issue/Provenance.hs @@ -0,0 +1,64 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Issue.Provenance + ( Provenance (..), + provenanceFromHEAD, + ) +where + +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.Encoding (decodeUtf8) +import Data.Time.Calendar (Day (..), toModifiedJulianDay) +import Data.Time.Clock (DiffTime, UTCTime (..), picosecondsToDiffTime) +import GHC.Generics (Generic) +import Process (sh) +import System.Process.Typed (setWorkingDir) +import Prelude hiding (lines) + +data Provenance = Provenance + { firstCommit :: Text, + date :: UTCTime, + authorEmail :: Text, + authorName :: Text + } + deriving (Show, Generic, Binary) + +-- 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. +-- +-- [1] https://hackage.haskell.org/package/binary-orphans-0.1.5.1/docs/src/Data-Binary-Orphans.html#line-132 +instance Binary UTCTime where + get = UTCTime <$> get <*> get + put (UTCTime d dt) = put d >> put dt + +instance Binary Day where + get = fmap ModifiedJulianDay get + put = put . toModifiedJulianDay + +instance Binary DiffTime where + get = fmap picosecondsToDiffTime get + put = (put :: Pico -> Put) . realToFrac + +provenanceFromHEAD :: FilePath -> IO (Maybe Provenance) +provenanceFromHEAD 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 : _ -> + let date = read (unpack rawDate) + in Just + Provenance + { firstCommit = firstCommit', + date = date, + authorEmail = authorEmail, + authorName = authorName + } + _ -> + Nothing |