remove `StoreT` type

StateT should not be an instance of `MonadUnliftIO`.

This reverts commit d441ab33582975ff9eda162db952f2ec5da59223.

2 files changed, 25 insertions, 92 deletions

diff --git a/app/Main.hs b/app/Main.hs
index bb8947d..47f0280 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -12,8 +12,11 @@ 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 ((</>))
@@ -143,7 +146,9 @@ query (Select fs c js ws) = do
   where
     ls c =
       filter (not . (isSuffixOf "/"))
-        <$> S.withStore "." "HEAD" (S.listDirectory c)
+        <$> S.withStore "." do
+          Just cid <- fmap Tagged <$> resolveReference "HEAD"
+          S.listDirectory cid c
 
 combine :: [Record J.Value] -> [Join [Record J.Value]] -> [[Record J.Value]]
 combine vs js = combine' (map (: []) vs) js
@@ -192,9 +197,9 @@ data DecodeException = DecodeException
 instance Exception DecodeException
 
 decodeFile :: J.FromJSON a => FilePath -> IO a
-decodeFile fp =
-  S.withStore "." "HEAD" $
-    fromMaybe (throw DecodeException) . J.decode <$> S.readFile fp
+decodeFile fp = S.withStore "." do
+  Just cid <- fmap Tagged <$> resolveReference "HEAD"
+  fromMaybe (throw DecodeException) . J.decode <$> S.readFile cid fp
 
 select :: FieldSelector -> [Record J.Value] -> J.Value
 select All vs =
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