1 files changed, 16 insertions, 88 deletions

diff --git a/app/Store.hs b/app/Store.hs
index ace8ea9..704a1cc 100644
--- a/app/Store.hs
+++ b/app/Store.hs
@@ -2,104 +2,43 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Store
-  ( StoreT (..),
-    withStore,
+  ( withStore,
     listDirectory,
     readFile,
   )
 where
 
 import Control.Arrow (first)
-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.Catch
+import Control.Monad.IO.Unlift (MonadUnliftIO)
 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 (HasLgRepo (getRepository), LgRepo, OidPtr, lgFactory)
-import Git.Libgit2 qualified as GB
+import Git.Libgit2 (LgRepo, lgFactory)
 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 ::
-  (MonadUnliftIO m, MonadMask m, MonadFail m) =>
+  (MonadMask m, MonadUnliftIO m) =>
   FilePath ->
-  RefName ->
-  StoreT (ReaderT LgRepo m) a ->
+  ReaderT LgRepo m a ->
   m a
-withStore fp ref act = withRepository lgFactory fp do
-  Just cid <- resolveReference ref
-  evalStateT (unStoreT act) cid
+withStore = withRepository lgFactory
 
 listDirectory ::
-  ( MonadState OidPtr m,
-    MonadMask m,
-    MonadUnliftIO m,
-    HasLgRepo m
-  ) =>
+  MonadGit r m =>
+  CommitOid r ->
   FilePath ->
   m [FilePath]
-listDirectory dir' = do
+listDirectory cid 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
@@ -128,14 +67,7 @@ data InappropriateType = InappropriateType String FilePath
 instance Exception InappropriateType
 
 class Readable a where
-  readFile ::
-    ( MonadState OidPtr m,
-      MonadMask m,
-      MonadUnliftIO m,
-      HasLgRepo m
-    ) =>
-    FilePath ->
-    m a
+  readFile :: MonadGit r m => CommitOid r -> FilePath -> m a
 
 instance Readable T.Text where
   readFile = readFile' catBlobUtf8
@@ -147,16 +79,12 @@ instance Readable LB.ByteString where
   readFile = readFile' catBlobLazy
 
 readFile' ::
-  ( MonadState OidPtr m,
-    MonadMask m,
-    MonadUnliftIO m,
-    HasLgRepo m
-  ) =>
-  (Tagged LgRepo OidPtr -> m b) ->
+  MonadGit r m =>
+  (BlobOid r -> m a) ->
+  CommitOid r ->
   FilePath ->
-  m b
-readFile' cat fp = do
-  cid <- Tagged <$> get
+  m a
+readFile' cat cid fp = do
   tid <- (.commitTree) <$> lookupCommit cid
   tree <- lookupTree tid
   maybe