{-# 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
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