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

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

import Path
import Path.IO
import Hledger.Flow.Types (HasBaseDir, BaseDir, RunDir, baseDir)
import Hledger.Flow.PathHelpers

import Data.Maybe

import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad (when)

import qualified Turtle (liftIO, repr, stripPrefix)
import qualified Data.Text as T
import qualified Data.Text.IO as T

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

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

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

determineBaseDirFromStartDir' :: (MonadIO m, MonadThrow m) => AbsDir -> AbsDir -> m (BaseDir, RunDir)
determineBaseDirFromStartDir' :: BaseDir -> BaseDir -> m (BaseDir, RunDir)
determineBaseDirFromStartDir' BaseDir
startDir BaseDir
possibleBaseDir = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.when (BaseDir -> BaseDir
forall b t. Path b t -> Path b Dir
parent BaseDir
possibleBaseDir BaseDir -> BaseDir -> Bool
forall a. Eq a => a -> a -> Bool
== BaseDir
possibleBaseDir) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ PathException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (BaseDir -> PathException
MissingBaseDir BaseDir
startDir)
  Bool
foundBaseDir <- BaseDir -> m Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist (BaseDir -> m Bool) -> BaseDir -> m Bool
forall a b. (a -> b) -> a -> b
$ BaseDir
possibleBaseDir BaseDir -> RunDir -> BaseDir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> [reldir|import|]
  if Bool
foundBaseDir then
    do
      RunDir
runDir <- BaseDir -> BaseDir -> m RunDir
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
BaseDir -> BaseDir -> m RunDir
limitRunDir BaseDir
possibleBaseDir BaseDir
startDir
      (BaseDir, RunDir) -> m (BaseDir, RunDir)
forall (m :: * -> *) a. Monad m => a -> m a
return (BaseDir
possibleBaseDir, RunDir
runDir)
    else BaseDir -> BaseDir -> m (BaseDir, RunDir)
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
BaseDir -> BaseDir -> m (BaseDir, RunDir)
determineBaseDirFromStartDir' BaseDir
startDir (BaseDir -> m (BaseDir, RunDir)) -> BaseDir -> m (BaseDir, RunDir)
forall a b. (a -> b) -> a -> b
$ BaseDir -> BaseDir
forall b t. Path b t -> Path b Dir
parent BaseDir
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 :: BaseDir -> BaseDir -> m RunDir
limitRunDir BaseDir
bd BaseDir
absRunDir = do
  RunDir
rel <- BaseDir -> BaseDir -> m (RelPath BaseDir)
forall path (m :: * -> *).
(AnyPath path, MonadThrow m) =>
BaseDir -> path -> m (RelPath path)
makeRelative BaseDir
bd BaseDir
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 = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"Changing runDir from " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RunDir -> FilePath
forall a text. (Show a, IsString text) => a -> text
Turtle.repr RunDir
rel FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RunDir -> FilePath
forall a text. (Show a, IsString text) => a -> text
Turtle.repr RunDir
newRunDir :: T.Text
    IO () -> m ()
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 (m :: * -> *) a. Monad m => a -> m a
return RunDir
newRunDir

composeN :: Int -> (a -> a) -> (a -> a)
composeN :: 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
nInt -> 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 :: o -> TurtlePath -> TurtlePath
relativeToBase o
opts = TurtlePath -> TurtlePath -> TurtlePath
relativeToBase' (TurtlePath -> TurtlePath -> TurtlePath)
-> TurtlePath -> TurtlePath -> TurtlePath
forall a b. (a -> b) -> a -> b
$ BaseDir -> TurtlePath
forall b t. Path b t -> TurtlePath
pathToTurtle (o -> BaseDir
forall a. HasBaseDir a => a -> BaseDir
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 :: o -> TurtlePath
turtleBaseDir o
opts = BaseDir -> TurtlePath
forall b t. Path b t -> TurtlePath
pathToTurtle (BaseDir -> TurtlePath) -> BaseDir -> TurtlePath
forall a b. (a -> b) -> a -> b
$ o -> BaseDir
forall a. HasBaseDir a => a -> BaseDir
baseDir o
opts

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