From 06402a97eb3d112b7affc52b24f698d60d4c8ece Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Thu, 8 Feb 2024 15:20:11 +0100 Subject: remove `StoreT` type StateT should not be an instance of `MonadUnliftIO`. This reverts commit d441ab33582975ff9eda162db952f2ec5da59223. --- app/Main.hs | 13 +++++--- app/Store.hs | 104 +++++++++-------------------------------------------------- 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 -- cgit v1.2.3