add `StoreT` type

2 files changed, 92 insertions, 25 deletions

diff --git a/app/Main.hs b/app/Main.hs
index 47f0280..bb8947d 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -12,11 +12,8 @@ import Data.ByteString.Lazy.Char8 qualified as LB
 import Data.List (foldl', isSuffixOf)
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Set qualified as S
-import Data.String (IsString (fromString))
-import Data.Tagged (Tagged (Tagged))
 import Data.Text qualified as T
 import Debug.Trace (trace)
-import Git
 import Store qualified as S
 import System.Directory (setCurrentDirectory)
 import System.FilePath ((</>))
@@ -146,9 +143,7 @@ query (Select fs c js ws) = do
   where
     ls c =
       filter (not . (isSuffixOf "/"))
-        <$> S.withStore "." do
-          Just cid <- fmap Tagged <$> resolveReference "HEAD"
-          S.listDirectory cid c
+        <$> S.withStore "." "HEAD" (S.listDirectory c)
 
 combine :: [Record J.Value] -> [Join [Record J.Value]] -> [[Record J.Value]]
 combine vs js = combine' (map (: []) vs) js
@@ -197,9 +192,9 @@ data DecodeException = DecodeException
 instance Exception DecodeException
 
 decodeFile :: J.FromJSON a => FilePath -> IO a
-decodeFile fp = S.withStore "." do
-  Just cid <- fmap Tagged <$> resolveReference "HEAD"
-  fromMaybe (throw DecodeException) . J.decode <$> S.readFile cid fp
+decodeFile fp =
+  S.withStore "." "HEAD" $
+    fromMaybe (throw DecodeException) . J.decode <$> S.readFile fp
 
 select :: FieldSelector -> [Record J.Value] -> J.Value
 select All vs =
diff --git a/app/Store.hs b/app/Store.hs
index 704a1cc..ace8ea9 100644
--- a/app/Store.hs
+++ b/app/Store.hs
@@ -2,43 +2,104 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Store
-  ( withStore,
+  ( StoreT (..),
+    withStore,
     listDirectory,
     readFile,
   )
 where
 
 import Control.Arrow (first)
-import Control.Monad.Catch
-import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Control.Exception (Exception)
+import Control.Monad.Catch (MonadCatch (catch), MonadMask (generalBracket, mask, uninterruptibleMask), MonadThrow, throwM)
+import Control.Monad.IO.Unlift (MonadUnliftIO (withRunInIO))
 import Control.Monad.Reader (ReaderT)
+import Control.Monad.State (MonadState (state), StateT (StateT), evalStateT, get)
+import Control.Monad.Trans (MonadIO, lift, liftIO)
 import Data.ByteString qualified as B
 import Data.ByteString.Lazy qualified as LB
 import Data.ByteString.UTF8 qualified as B
 import Data.List (isPrefixOf, sort)
+import Data.Tagged (Tagged (Tagged))
 import Data.Text qualified as T
 import Git
-import Git.Libgit2 (LgRepo, lgFactory)
+import Git.Libgit2 (HasLgRepo (getRepository), LgRepo, OidPtr, lgFactory)
+import Git.Libgit2 qualified as GB
 import System.FilePath
 import Prelude hiding (readFile)
 
+data StoreT m a = StoreT
+  { unStoreT :: StateT OidPtr m a
+  }
+
+-- XXX `DeriveAnyClass` does not work for `StoreT`
+--
+-- The instances generated by `DeriveAnyClass` are empty..
+
+instance (Monad m, Applicative m) => Applicative (StoreT m) where
+  pure = StoreT . pure
+  f <*> x = StoreT $ unStoreT f <*> unStoreT x
+
+instance Functor m => Functor (StoreT m) where
+  fmap f = StoreT . fmap f . unStoreT
+
+instance Monad m => Monad (StoreT m) where
+  m >>= k = StoreT $ unStoreT m >>= unStoreT . k
+
+instance MonadThrow m => MonadThrow (StoreT m) where
+  throwM = StoreT . throwM
+
+instance MonadCatch m => MonadCatch (StoreT m) where
+  m `catch` h = StoreT $ unStoreT m `catch` (unStoreT . h)
+
+instance MonadIO m => MonadIO (StoreT m) where
+  liftIO = StoreT . liftIO
+
+instance Monad m => MonadState OidPtr (StoreT m) where
+  state = StoreT . state
+
+instance MonadMask m => MonadMask (StoreT m) where
+  mask f = StoreT $ mask (\g -> unStoreT (f (\m -> (StoreT (g (unStoreT m))))))
+  uninterruptibleMask f = StoreT $ uninterruptibleMask (\g -> unStoreT (f (\m -> (StoreT (g (unStoreT m))))))
+  generalBracket m n k = StoreT (generalBracket (unStoreT m) ((unStoreT .) . n) (unStoreT . k))
+
+instance MonadUnliftIO m => MonadUnliftIO (StateT s m) where
+  withRunInIO f =
+    StateT $ \s ->
+      (,s) <$> withRunInIO (\g -> f (\m -> g (evalStateT m s)))
+
+instance MonadUnliftIO m => MonadUnliftIO (StoreT m) where
+  withRunInIO f =
+    StoreT (withRunInIO (\g -> f (\m -> g (unStoreT m))))
+
+instance (HasLgRepo m, Monad m) => HasLgRepo (StoreT m) where
+  getRepository = StoreT $ lift GB.getRepository
+
 withStore ::
-  (MonadMask m, MonadUnliftIO m) =>
+  (MonadUnliftIO m, MonadMask m, MonadFail m) =>
   FilePath ->
-  ReaderT LgRepo m a ->
+  RefName ->
+  StoreT (ReaderT LgRepo m) a ->
   m a
-withStore = withRepository lgFactory
+withStore fp ref act = withRepository lgFactory fp do
+  Just cid <- resolveReference ref
+  evalStateT (unStoreT act) cid
 
 listDirectory ::
-  MonadGit r m =>
-  CommitOid r ->
+  ( MonadState OidPtr m,
+    MonadMask m,
+    MonadUnliftIO m,
+    HasLgRepo m
+  ) =>
   FilePath ->
   m [FilePath]
-listDirectory cid dir' = do
+listDirectory dir' = do
   let dir = normalise $ if hasDrive dir' then dir' else joinDrive "/" dir'
       n = length (splitPath dir)
+  cid <- Tagged <$> get
   tid <- (.commitTree) <$> lookupCommit cid
   tree <- lookupTree tid
   sort
@@ -67,7 +128,14 @@ data InappropriateType = InappropriateType String FilePath
 instance Exception InappropriateType
 
 class Readable a where
-  readFile :: MonadGit r m => CommitOid r -> FilePath -> m a
+  readFile ::
+    ( MonadState OidPtr m,
+      MonadMask m,
+      MonadUnliftIO m,
+      HasLgRepo m
+    ) =>
+    FilePath ->
+    m a
 
 instance Readable T.Text where
   readFile = readFile' catBlobUtf8
@@ -79,12 +147,16 @@ instance Readable LB.ByteString where
   readFile = readFile' catBlobLazy
 
 readFile' ::
-  MonadGit r m =>
-  (BlobOid r -> m a) ->
-  CommitOid r ->
+  ( MonadState OidPtr m,
+    MonadMask m,
+    MonadUnliftIO m,
+    HasLgRepo m
+  ) =>
+  (Tagged LgRepo OidPtr -> m b) ->
   FilePath ->
-  m a
-readFile' cat cid fp = do
+  m b
+readFile' cat fp = do
+  cid <- Tagged <$> get
   tid <- (.commitTree) <$> lookupCommit cid
   tree <- lookupTree tid
   maybe