{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

module Hledger.Flow.BaseDir
  ( determineBaseDir,
    relativeToBase,
    relativeToBase',
    turtleBaseDir,
    effectiveRunDir,
  )
where

import Control.Monad (when)
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.IO.Class (MonadIO)
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Hledger.Flow.PathHelpers
import Hledger.Flow.Types (BaseDir, HasBaseDir, RunDir, baseDir)
import Path
import Path.IO
import qualified Turtle (liftIO, repr, stripPrefix)

determineBaseDir :: Maybe TurtlePath -> IO (BaseDir, RunDir)
determineBaseDir :: Maybe TurtlePath -> IO (Path Abs Dir, RunDir)
determineBaseDir Maybe TurtlePath
suppliedDir = do
  Path Abs Dir
pwd <- IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
  Path Abs Dir -> Maybe TurtlePath -> IO (Path Abs Dir, RunDir)
determineBaseDir' Path Abs Dir
pwd Maybe TurtlePath
suppliedDir

determineBaseDir' :: AbsDir -> Maybe TurtlePath -> IO (BaseDir, RunDir)
determineBaseDir' :: Path Abs Dir -> Maybe TurtlePath -> IO (Path Abs Dir, RunDir)
determineBaseDir' Path Abs Dir
pwd (Just TurtlePath
suppliedDir) = do
  Path Abs Dir
absDir <- Path Abs Dir -> TurtlePath -> IO (Path Abs Dir)
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> TurtlePath -> m (Path Abs Dir)
turtleToAbsDir Path Abs Dir
pwd TurtlePath
suppliedDir
  Path Abs Dir -> IO (Path Abs Dir, RunDir)
determineBaseDirFromStartDir Path Abs Dir
absDir
determineBaseDir' Path Abs Dir
pwd Maybe TurtlePath
Nothing = Path Abs Dir -> IO (Path Abs Dir, RunDir)
determineBaseDirFromStartDir Path Abs Dir
pwd

determineBaseDirFromStartDir :: AbsDir -> IO (BaseDir, RunDir)
determineBaseDirFromStartDir :: Path Abs Dir -> IO (Path Abs Dir, RunDir)
determineBaseDirFromStartDir Path Abs Dir
startDir = Path Abs Dir -> Path Abs Dir -> IO (Path Abs Dir, RunDir)
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> Path Abs Dir -> m (Path Abs Dir, RunDir)
determineBaseDirFromStartDir' Path Abs Dir
startDir Path Abs Dir
startDir

determineBaseDirFromStartDir' :: (MonadIO m, MonadThrow m) => AbsDir -> AbsDir -> m (BaseDir, RunDir)
determineBaseDirFromStartDir' :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> Path Abs Dir -> m (Path Abs Dir, RunDir)
determineBaseDirFromStartDir' Path Abs Dir
startDir Path Abs Dir
possibleBaseDir = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.when (Path Abs Dir -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs Dir
possibleBaseDir Path Abs Dir -> Path Abs Dir -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs Dir
possibleBaseDir) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ PathException -> m ()
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (Path Abs Dir -> PathException
MissingBaseDir Path Abs Dir
startDir)
  Bool
foundBaseDir <- Path Abs Dir -> m Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist (Path Abs Dir -> m Bool) -> Path Abs Dir -> m Bool
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
possibleBaseDir Path Abs Dir -> RunDir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> [reldir|import|]
  if Bool
foundBaseDir
    then do
      RunDir
runDir <- Path Abs Dir -> Path Abs Dir -> m RunDir
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> Path Abs Dir -> m RunDir
limitRunDir Path Abs Dir
possibleBaseDir Path Abs Dir
startDir
      (Path Abs Dir, RunDir) -> m (Path Abs Dir, RunDir)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs Dir
possibleBaseDir, RunDir
runDir)
    else Path Abs Dir -> Path Abs Dir -> m (Path Abs Dir, RunDir)
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> Path Abs Dir -> m (Path Abs Dir, RunDir)
determineBaseDirFromStartDir' Path Abs Dir
startDir (Path Abs Dir -> m (Path Abs Dir, RunDir))
-> Path Abs Dir -> m (Path Abs Dir, RunDir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs Dir
possibleBaseDir

-- | We have unexpected behaviour when the runDir is deeper than the account directory,
-- e.g. "1-in" or the year directory. Specifically, include files are generated incorrectly
-- and some journals are written entirely outside of the baseDir.
-- limitRunDir can possibly removed if the above is fixed.
limitRunDir :: (MonadIO m, MonadThrow m) => BaseDir -> AbsDir -> m RunDir
limitRunDir :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> Path Abs Dir -> m RunDir
limitRunDir Path Abs Dir
bd Path Abs Dir
absRunDir = do
  RunDir
rel <- Path Abs Dir -> Path Abs Dir -> m (RelPath (Path Abs Dir))
forall path (m :: * -> *).
(AnyPath path, MonadThrow m) =>
Path Abs Dir -> path -> m (RelPath path)
forall (m :: * -> *).
MonadThrow m =>
Path Abs Dir -> Path Abs Dir -> m (RelPath (Path Abs Dir))
makeRelative Path Abs Dir
bd Path Abs Dir
absRunDir
  let runDirDepth :: Int
runDirDepth = RunDir -> Int
forall b. Path b Dir -> Int
pathSize RunDir
rel
  let fun :: Path b Dir -> Path b Dir
fun = Int -> (Path b Dir -> Path b Dir) -> Path b Dir -> Path b Dir
forall a. Int -> (a -> a) -> a -> a
composeN (Int
runDirDepth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4) Path b Dir -> Path b Dir
forall b t. Path b t -> Path b Dir
parent
  let newRunDir :: RunDir
newRunDir = RunDir -> RunDir
forall {b}. Path b Dir -> Path b Dir
fun RunDir
rel
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
runDirDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    let msg :: Text
msg = TurtlePath -> Text
T.pack (TurtlePath -> Text) -> TurtlePath -> Text
forall a b. (a -> b) -> a -> b
$ TurtlePath
"Changing runDir from " TurtlePath -> TurtlePath -> TurtlePath
forall a. [a] -> [a] -> [a]
++ RunDir -> TurtlePath
forall a text. (Show a, IsString text) => a -> text
Turtle.repr RunDir
rel TurtlePath -> TurtlePath -> TurtlePath
forall a. [a] -> [a] -> [a]
++ TurtlePath
" to " TurtlePath -> TurtlePath -> TurtlePath
forall a. [a] -> [a] -> [a]
++ RunDir -> TurtlePath
forall a text. (Show a, IsString text) => a -> text
Turtle.repr RunDir
newRunDir :: T.Text
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Turtle.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
msg
  RunDir -> m RunDir
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return RunDir
newRunDir

composeN :: Int -> (a -> a) -> (a -> a)
composeN :: forall a. Int -> (a -> a) -> a -> a
composeN Int
n a -> a
f
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = a -> a
forall a. a -> a
id
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = a -> a
f
  | Bool
otherwise = Int -> (a -> a) -> a -> a
forall a. Int -> (a -> a) -> a -> a
composeN (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (a -> a
f (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f)

relativeToBase :: (HasBaseDir o) => o -> TurtlePath -> TurtlePath
relativeToBase :: forall o. HasBaseDir o => o -> TurtlePath -> TurtlePath
relativeToBase o
opts = TurtlePath -> TurtlePath -> TurtlePath
relativeToBase' (TurtlePath -> TurtlePath -> TurtlePath)
-> TurtlePath -> TurtlePath -> TurtlePath
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> TurtlePath
forall b t. Path b t -> TurtlePath
pathToTurtle (o -> Path Abs Dir
forall a. HasBaseDir a => a -> Path Abs Dir
baseDir o
opts)

relativeToBase' :: TurtlePath -> TurtlePath -> TurtlePath
relativeToBase' :: TurtlePath -> TurtlePath -> TurtlePath
relativeToBase' TurtlePath
bd TurtlePath
p =
  if TurtlePath -> TurtlePath
forceTrailingSlash TurtlePath
bd TurtlePath -> TurtlePath -> Bool
forall a. Eq a => a -> a -> Bool
== TurtlePath -> TurtlePath
forceTrailingSlash TurtlePath
p
    then TurtlePath
"./"
    else
      TurtlePath -> Maybe TurtlePath -> TurtlePath
forall a. a -> Maybe a -> a
fromMaybe TurtlePath
p (Maybe TurtlePath -> TurtlePath) -> Maybe TurtlePath -> TurtlePath
forall a b. (a -> b) -> a -> b
$ TurtlePath -> TurtlePath -> Maybe TurtlePath
Turtle.stripPrefix (TurtlePath -> TurtlePath
forceTrailingSlash TurtlePath
bd) TurtlePath
p

turtleBaseDir :: (HasBaseDir o) => o -> TurtlePath
turtleBaseDir :: forall o. HasBaseDir o => o -> TurtlePath
turtleBaseDir o
opts = Path Abs Dir -> TurtlePath
forall b t. Path b t -> TurtlePath
pathToTurtle (Path Abs Dir -> TurtlePath) -> Path Abs Dir -> TurtlePath
forall a b. (a -> b) -> a -> b
$ o -> Path Abs Dir
forall a. HasBaseDir a => a -> Path Abs Dir
baseDir o
opts

effectiveRunDir :: BaseDir -> RunDir -> AbsDir
effectiveRunDir :: Path Abs Dir -> RunDir -> Path Abs Dir
effectiveRunDir Path Abs Dir
bd RunDir
rd = do
  let baseImportDir :: Path Abs Dir
baseImportDir = Path Abs Dir
bd Path Abs Dir -> RunDir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> [Path.reldir|import|]
  let absRunDir :: Path Abs Dir
absRunDir = Path Abs Dir
bd Path Abs Dir -> RunDir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> RunDir
rd
  if Path Abs Dir
absRunDir Path Abs Dir -> Path Abs Dir -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs Dir
bd then Path Abs Dir
baseImportDir else Path Abs Dir
absRunDir