{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Store
  ( StoreT (..),
    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.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 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) =>
  FilePath ->
  RefName ->
  StoreT (ReaderT LgRepo m) a ->
  m a
withStore fp ref act = withRepository lgFactory fp do
  Just cid <- resolveReference ref
  evalStateT (unStoreT act) cid

listDirectory ::
  ( MonadState OidPtr m,
    MonadMask m,
    MonadUnliftIO m,
    HasLgRepo m
  ) =>
  FilePath ->
  m [FilePath]
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
    . map (makeRelative dir)
    . filter ((== n + 1) . length . splitPath)
    . filter (isPrefixOf (addTrailingPathSeparator dir))
    . map fst
    . map
      ( \e ->
          case snd e of
            BlobEntry _ _ -> e
            CommitEntry _ -> error "XXX commit entry"
            TreeEntry _ -> first addTrailingPathSeparator e
      )
    . map (first (("/" <>) . B.toString))
    <$> listTreeEntries tree

data DoesNotExist = DoesNotExist String FilePath
  deriving (Show)

instance Exception DoesNotExist

data InappropriateType = InappropriateType String FilePath
  deriving (Show)

instance Exception InappropriateType

class Readable a where
  readFile ::
    ( MonadState OidPtr m,
      MonadMask m,
      MonadUnliftIO m,
      HasLgRepo m
    ) =>
    FilePath ->
    m a

instance Readable T.Text where
  readFile = readFile' catBlobUtf8

instance Readable B.ByteString where
  readFile = readFile' catBlob

instance Readable LB.ByteString where
  readFile = readFile' catBlobLazy

readFile' ::
  ( MonadState OidPtr m,
    MonadMask m,
    MonadUnliftIO m,
    HasLgRepo m
  ) =>
  (Tagged LgRepo OidPtr -> m b) ->
  FilePath ->
  m b
readFile' cat fp = do
  cid <- Tagged <$> get
  tid <- (.commitTree) <$> lookupCommit cid
  tree <- lookupTree tid
  maybe
    (throwM (DoesNotExist "readFile" fp))
    ( \e ->
        case e of
          BlobEntry bid _ -> cat bid
          CommitEntry _ -> error "XXX commit entry"
          TreeEntry _ -> throwM (InappropriateType "readFile" fp)
    )
    =<< treeEntry tree (B.fromString fp)