{-# LANGUAGE TemplateHaskell #-}
module HMGit.Internal.Core.Runner.HMGitConfig (
    HMGitConfig (..)
  , hmGitConfig
) where

import           HMGit.Internal.Exceptions (noSuchThing)

import           Control.Exception.Safe    (MonadThrow, throw)
import           Control.Monad.Extra       (andM, ifM)
import           Control.Monad.Fix         (fix)
import           Control.Monad.IO.Class    (MonadIO (..))
import           Path                      (Dir, Rel)
import qualified Path                      as P
import qualified Path.IO                   as P
import           Text.Printf               (printf)

data HMGitConfig = HMGitConfig {
    HMGitConfig -> Path Abs Dir
hmGitDir       :: P.Path P.Abs P.Dir
  , HMGitConfig -> Int
hmGitTreeLimit :: Int
  } | HMGitConfigInit

isHMGitDir :: MonadIO m
    => P.Path P.Abs P.Dir
    -> m Bool
isHMGitDir :: Path Abs Dir -> m Bool
isHMGitDir Path Abs Dir
fp = [m Bool] -> m Bool
forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM [
    Path Abs Dir -> m Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
P.doesDirExist Path Abs Dir
fp
  , Path Abs Dir -> m Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
P.doesDirExist (Path Abs Dir -> m Bool) -> Path Abs Dir -> m Bool
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
fp Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> $(P.mkRelDir "objects")
  , Path Abs Dir -> m Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
P.doesDirExist (Path Abs Dir -> m Bool) -> Path Abs Dir -> m Bool
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
fp Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> $(P.mkRelDir "refs")
  ]

getHMGitPath :: (MonadThrow m, MonadIO m)
    => String
    -> m (P.Path P.Abs P.Dir)
getHMGitPath :: [Char] -> m (Path Abs Dir)
getHMGitPath [Char]
dbName = do
    Path Abs Dir
currentDir <- m (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
P.getCurrentDir
    Path Rel Dir
dbName' <- [Char] -> m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
P.parseRelDir [Char]
dbName
    ((Path Abs Dir -> m (Path Abs Dir))
-> Path Abs Dir -> m (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
currentDir) ((Path Abs Dir -> m (Path Abs Dir)) -> m (Path Abs Dir))
-> (((Path Abs Dir -> m (Path Abs Dir))
     -> Path Abs Dir -> m (Path Abs Dir))
    -> Path Abs Dir -> m (Path Abs Dir))
-> ((Path Abs Dir -> m (Path Abs Dir))
    -> Path Abs Dir -> m (Path Abs Dir))
-> m (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Path Abs Dir -> m (Path Abs Dir))
 -> Path Abs Dir -> m (Path Abs Dir))
-> Path Abs Dir -> m (Path Abs Dir)
forall a. (a -> a) -> a
fix (((Path Abs Dir -> m (Path Abs Dir))
  -> Path Abs Dir -> m (Path Abs Dir))
 -> m (Path Abs Dir))
-> ((Path Abs Dir -> m (Path Abs Dir))
    -> Path Abs Dir -> m (Path Abs Dir))
-> m (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir -> m (Path Abs Dir)
f Path Abs Dir
cwd ->
        m Bool -> m (Path Abs Dir) -> m (Path Abs Dir) -> m (Path Abs Dir)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Bool -> Bool
not (Bool -> Bool) -> m Bool -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> m Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
P.doesDirExist Path Abs Dir
cwd)
            (IOException -> m (Path Abs Dir)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (IOException -> m (Path Abs Dir))
-> IOException -> m (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IOException
noSuchThing [Char]
errMsg ([Char] -> IOException) -> [Char] -> IOException
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
P.toFilePath Path Abs Dir
cwd)
          (m (Path Abs Dir) -> m (Path Abs Dir))
-> m (Path Abs Dir) -> m (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ let expectedHMGitDirPath :: Path Abs Dir
expectedHMGitDirPath = Path Abs Dir
cwd Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> Path Rel Dir
dbName' in
                m Bool -> m (Path Abs Dir) -> m (Path Abs Dir) -> m (Path Abs Dir)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Path Abs Dir -> m Bool
forall (m :: * -> *). MonadIO m => Path Abs Dir -> m Bool
isHMGitDir Path Abs Dir
expectedHMGitDirPath)
                    (Path Abs Dir -> m (AbsPath (Path Abs Dir))
forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (AbsPath path)
P.canonicalizePath Path Abs Dir
expectedHMGitDirPath)
                  (m (Path Abs Dir) -> m (Path Abs Dir))
-> m (Path Abs Dir) -> m (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ if Path Abs Dir -> Path Abs Dir
forall b t. Path b t -> Path b Dir
P.parent Path Abs Dir
cwd Path Abs Dir -> Path Abs Dir -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs Dir
cwd
                    then IOException -> m (Path Abs Dir)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (IOException -> m (Path Abs Dir))
-> IOException -> m (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IOException
noSuchThing [Char]
errMsg ([Char] -> IOException) -> [Char] -> IOException
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
P.toFilePath Path Abs Dir
cwd
                    else Path Abs Dir -> m (Path Abs Dir)
f (Path Abs Dir -> Path Abs Dir
forall b t. Path b t -> Path b Dir
P.parent Path Abs Dir
cwd)
    where
        errMsg :: [Char]
errMsg = [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"not a git repository (or any of the parent directories): %s" [Char]
dbName

hmGitConfig :: (MonadThrow m, MonadIO m)
    => String
    -> m HMGitConfig
hmGitConfig :: [Char] -> m HMGitConfig
hmGitConfig [Char]
dbName = do
    Path Abs Dir
hmGitPath <- [Char] -> m (Path Abs Dir)
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
[Char] -> m (Path Abs Dir)
getHMGitPath [Char]
dbName
    HMGitConfig -> m HMGitConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HMGitConfig -> m HMGitConfig) -> HMGitConfig -> m HMGitConfig
forall a b. (a -> b) -> a -> b
$ HMGitConfig :: Path Abs Dir -> Int -> HMGitConfig
HMGitConfig {
        hmGitDir :: Path Abs Dir
hmGitDir = Path Abs Dir
hmGitPath
      , hmGitTreeLimit :: Int
hmGitTreeLimit = Int
1000
      }