{-# 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 suppliedDir = do
pwd <- getCurrentDir
determineBaseDir' pwd suppliedDir
determineBaseDir' :: AbsDir -> Maybe TurtlePath -> IO (BaseDir, RunDir)
determineBaseDir' pwd (Just suppliedDir) = do
absDir <- turtleToAbsDir pwd suppliedDir
determineBaseDirFromStartDir absDir
determineBaseDir' pwd Nothing = determineBaseDirFromStartDir pwd
determineBaseDirFromStartDir :: AbsDir -> IO (BaseDir, RunDir)
determineBaseDirFromStartDir startDir = determineBaseDirFromStartDir' startDir startDir
determineBaseDirFromStartDir' :: (MonadIO m, MonadThrow m) => AbsDir -> AbsDir -> m (BaseDir, RunDir)
determineBaseDirFromStartDir' startDir possibleBaseDir = do
Control.Monad.when (parent possibleBaseDir == possibleBaseDir) $ throwM (MissingBaseDir startDir)
foundBaseDir <- doesDirExist $ possibleBaseDir </> [reldir|import|]
if foundBaseDir then
do
runDir <- limitRunDir possibleBaseDir startDir
return (possibleBaseDir, runDir)
else determineBaseDirFromStartDir' startDir $ parent possibleBaseDir
limitRunDir :: (MonadIO m, MonadThrow m) => BaseDir -> AbsDir -> m RunDir
limitRunDir bd absRunDir = do
rel <- makeRelative bd absRunDir
let runDirDepth = pathSize rel
let fun = composeN (runDirDepth - 4) parent
let newRunDir = fun rel
when (runDirDepth > 4) $ do
let msg = T.pack $ "Changing runDir from " ++ Turtle.repr rel ++ " to " ++ Turtle.repr newRunDir :: T.Text
Turtle.liftIO $ T.putStrLn msg
return newRunDir
composeN :: Int -> (a -> a) -> (a -> a)
composeN n f | n < 1 = id
| n == 1 = f
| otherwise = composeN (n-1) (f . f)
relativeToBase :: HasBaseDir o => o -> TurtlePath -> TurtlePath
relativeToBase opts = relativeToBase' $ pathToTurtle (baseDir opts)
relativeToBase' :: TurtlePath -> TurtlePath -> TurtlePath
relativeToBase' bd p = if forceTrailingSlash bd == forceTrailingSlash p then "./" else
fromMaybe p $ Turtle.stripPrefix (forceTrailingSlash bd) p
turtleBaseDir :: HasBaseDir o => o -> TurtlePath
turtleBaseDir opts = pathToTurtle $ baseDir opts
effectiveRunDir :: BaseDir -> RunDir -> AbsDir
effectiveRunDir bd rd = do
let baseImportDir = bd </> [Path.reldir|import|]
let absRunDir = bd </> rd
if absRunDir == bd then baseImportDir else absRunDir