From 0391f3cb867db458e6d607facd424f627c99f437 Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Mon, 16 Oct 2023 11:55:48 +0200
Subject: refactor `Issue.Provenance` from `Issue`
---
app/Issue.hs | 55 +++---------------------------------------
app/Issue/Provenance.hs | 64 +++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 67 insertions(+), 52 deletions(-)
create mode 100644 app/Issue/Provenance.hs
(limited to 'app')
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
--
cgit v1.2.3