add basic caching of Issue's

4 files changed, 33 insertions, 6 deletions

diff --git a/app/History.hs b/app/History.hs
index fad911a..0621fd8 100644
--- a/app/History.hs
+++ b/app/History.hs
@@ -5,6 +5,7 @@ module History (getIssues, InvalidTreeGrepperResult (..), UnknownFileExtension (
 
 import Control.Exception (Exception, catch, handle, throw)
 import Data.Aeson (eitherDecode)
+import Data.Binary (Binary, decodeFile, encodeFile)
 import Data.ByteString.Lazy.Char8 qualified as L8
 import Data.List (intercalate)
 import Data.Maybe (catMaybes, mapMaybe)
@@ -14,7 +15,7 @@ import Data.Text.Encoding (decodeUtf8)
 import Issue (Issue (..), fromMatch, id)
 import Issue.Filter (Filter, applyFilter)
 import Process (quote, sh, sh_)
-import System.Directory (getCurrentDirectory, setCurrentDirectory)
+import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory, setCurrentDirectory)
 import System.Exit (ExitCode (ExitFailure), exitWith)
 import System.FilePath (takeExtension, (</>))
 import System.IO.Temp (withSystemTempDirectory)
@@ -41,7 +42,7 @@ instance Exception InvalidTreeGrepperResult
 listIssues :: [Filter] -> [FilePath] -> IO [Issue]
 listIssues filters files = do
   commits <- fmap (lines . decodeUtf8 . L8.toStrict) $ sh ("git log --format=%H")
-  issueses <- mapM (\commit -> listIssuesOf commit filters files) commits
+  issueses <- mapM (\commit -> cached commit (\_ -> listIssuesOf commit filters files)) commits
   (currentIssues, historicalIssues) <-
     case issueses of
       currentIssues : historicalIssueses ->
@@ -65,6 +66,19 @@ merge (issue, issues) =
     provenance : _ ->
       issue {provenance = Just provenance}
 
+cached :: Binary a => Text -> (Text -> IO a) -> IO a
+cached commit func = do
+  cwd <- getCurrentDirectory
+  createDirectoryIfMissing True (cwd ++ "/.anissue")
+  let file = (cwd ++ "/.anissue/" ++ unpack commit)
+  fileExists <- doesFileExist file
+  if fileExists
+    then decodeFile file
+    else do
+      blob <- func commit
+      encodeFile file blob
+      pure blob
+
 listIssuesOf :: Text -> [Filter] -> [FilePath] -> IO [Issue]
 listIssuesOf commit filters files = do
   cwd <- getCurrentDirectory
diff --git a/app/Issue.hs b/app/Issue.hs
index ba8baa8..f7227f1 100644
--- a/app/Issue.hs
+++ b/app/Issue.hs
@@ -1,10 +1,12 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DisambiguateRecordFields #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Issue (Issue (..), Provenance (..), fromMatch, id) where
 
+import Data.Binary (Binary, get, put)
 import Data.ByteString.Lazy (toStrict)
 import Data.ByteString.Lazy.Char8 (unpack)
 import Data.List (find, foldl')
@@ -13,6 +15,7 @@ import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.Encoding (decodeUtf8)
 import Data.Time.Clock (UTCTime)
+import GHC.Generics (Generic)
 import Issue.Tag (Tag (..))
 import Issue.Tag qualified as I
 import Issue.Text qualified as I
@@ -34,7 +37,7 @@ data Issue = Issue
     tags :: [Tag],
     internalTags :: [Tag]
   }
-  deriving (Show)
+  deriving (Show, Binary, Generic)
 
 data Provenance = Provenance
   { firstCommit :: Text,
@@ -42,7 +45,12 @@ data Provenance = Provenance
     authorEmail :: Text,
     authorName :: Text
   }
-  deriving (Show)
+  deriving (Show, Generic, Binary)
+
+instance Binary UTCTime where
+  -- TODO Serialize UTCTime using POSIX time stamps
+  put = put . show
+  get = fmap read get
 
 id :: Issue -> Maybe String
 id issue =
diff --git a/app/Issue/Tag.hs b/app/Issue/Tag.hs
index af12331..7147cb1 100644
--- a/app/Issue/Tag.hs
+++ b/app/Issue/Tag.hs
@@ -1,14 +1,17 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DeriveAnyClass #-}
 
 module Issue.Tag (Tag (..), extractTags, internalTags) where
 
 import Data.Maybe (catMaybes)
 import Data.Text (Text)
 import Data.Text qualified as T
+import Data.Binary (Binary)
+import GHC.Generics (Generic)
 
-data Tag = Tag Text Text deriving (Show)
+data Tag = Tag Text Text deriving (Show, Generic, Binary)
 
 extractTags :: Text -> [Tag]
 extractTags =
diff --git a/app/TreeGrepper/Match.hs b/app/TreeGrepper/Match.hs
index 7b8cde8..1072fbd 100644
--- a/app/TreeGrepper/Match.hs
+++ b/app/TreeGrepper/Match.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE DeriveAnyClass #-}
 
 module TreeGrepper.Match
   ( Match (..),
@@ -16,6 +17,7 @@ import Data.Ord (comparing)
 import Data.Text (Text)
 import Data.Text qualified as T
 import GHC.Generics (Generic)
+import Data.Binary (Binary)
 
 data Match = Match
   { kind :: String,
@@ -32,7 +34,7 @@ data Position = Position
   { row :: Int,
     column :: Int
   }
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show, Generic, Binary)
 
 instance Ord Position where
   compare = compare `on` (\p -> (p.row, p.column))