ImportHelpersTurtle.hs

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

-- | Generate journal include files and their relative include directives.
module Hledger.Flow.Import.ImportHelpersTurtle
  ( extraIncludesForFile,
    includePreamble,
    toIncludeFiles,
    toIncludeLine,
    writeIncludesFromInventory,
    writeToplevelAllYearsInclude,
    yearsIncludeMap,
  )
where

import Control.Concurrent.STM (TChan)
import Control.Monad (unless)
import qualified Data.List as List (isPrefixOf, nub, sort)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Hledger.Flow.BaseDir (relativeToBase, relativeToBase', turtleBaseDir)
import Hledger.Flow.Common (allYearsFileName, directivesFile, filterPaths, groupValuesBy, writeFiles, writeFiles')
import Hledger.Flow.Import.ImportHelpers (groupIncludesUpTo)
import Hledger.Flow.Import.Inventory (manualIncludeFiles, managedIncludeFiles)
import Hledger.Flow.Import.Types
import Hledger.Flow.Logging (logVerbose)
import Hledger.Flow.PathHelpers (AbsDir, AbsFile)
import Hledger.Flow.Types
import qualified Path
import qualified Path.IO as PathIO
import System.Directory (doesFileExist)
import qualified System.FilePath as FilePath
import System.FilePath ((</>))

isJournalFile :: FilePath -> Bool
isJournalFile f = FilePath.takeExtension f == ".journal"

yearsIncludeMap :: [FilePath] -> TurtleFileBundle
yearsIncludeMap = groupValuesBy allYearsPath

allYearsPath :: FilePath -> FilePath
allYearsPath journal = fst (FilePath.splitFileName journal) </> allYearsFileName

toIncludeFiles :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> TurtleFileBundle -> IO (Map.Map FilePath T.Text)
toIncludeFiles opts ch m = do
  preMap <- extraIncludes opts ch (Map.keys m) ["opening.journal"] ["pre-import.journal"] []
  postMap <- extraIncludes opts ch (Map.keys m) ["closing.journal"] ["post-import.journal"] ["prices.journal"]
  return $ (addPreamble . toIncludeFiles' preMap postMap) m

toIncludeFiles' :: TurtleFileBundle -> TurtleFileBundle -> TurtleFileBundle -> Map.Map FilePath T.Text
toIncludeFiles' preMap postMap = Map.mapWithKey $ generatedIncludeText preMap postMap

addPreamble :: Map.Map FilePath T.Text -> Map.Map FilePath T.Text
addPreamble = Map.map (\txt -> includePreamble <> "\n" <> txt)

toIncludeLine :: FilePath -> FilePath -> T.Text
toIncludeLine base file = "include " <> T.pack (map forwardSlash (relativeToBase' base file))
  where
    forwardSlash c = if FilePath.isPathSeparator c then '/' else c

generatedIncludeText :: TurtleFileBundle -> TurtleFileBundle -> FilePath -> [FilePath] -> T.Text
generatedIncludeText preMap postMap outputFile fs = do
  let preFiles = fromMaybe [] $ Map.lookup outputFile preMap
  let files = List.nub . List.sort $ fs
  let postFiles = fromMaybe [] $ Map.lookup outputFile postMap
  let lns = map (toIncludeLine $ FilePath.takeDirectory outputFile) $ preFiles ++ files ++ postFiles
  T.intercalate "\n" $ lns ++ [""]

includePreamble :: T.Text
includePreamble = "### Generated by hledger-flow - DO NOT EDIT ###\n"

writeFileMap :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> (TurtleFileBundle, TurtleFileBundle) -> IO [FilePath]
writeFileMap opts ch (m, allYears) = do
  _ <- writeFiles' $ (addPreamble . toIncludeFiles' Map.empty Map.empty) allYears
  writeFiles . (toIncludeFiles opts ch) $ m

writeIncludesFromInventory :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> AbsDir -> [AbsFile] -> [AbsFile] -> IO [AbsFile]
writeIncludesFromInventory opts ch stopAt inventory journals = do
  let base = baseDir opts
      importRoot = base Path.</> [Path.reldir|import|]
      journalFiles = filter (isJournalFile . Path.toFilePath) journals
  boundary <- Path.stripProperPrefix base stopAt
  unless (all (Path.isProperPrefixOf stopAt) journalFiles) $
    ioError (userError "Journal file outside the requested include directory")
  inputs <- mapM (Path.stripProperPrefix base) journalFiles
  manual <- manualIncludeFiles importRoot (filter (Path.isProperPrefixOf stopAt) inventory)
  seeds <- mapM (Path.stripProperPrefix base) manual
  let groups = Map.unionsWith (++)
        [ groupIncludesUpTo boundary inputs,
          groupIncludesUpTo boundary seeds,
          Map.fromList [(seed, []) | seed <- seeds]
        ]
      absolute file = Path.toFilePath (base Path.</> file)
      includes = Map.mapKeys absolute (Map.map (map absolute) groups)
      years = yearsIncludeMap (Map.keys includes)
      allAtStop = Path.toFilePath stopAt </> allYearsFileName
      indexes = Map.insertWith (++) allAtStop [] years
      current = Map.union includes indexes
  -- Empty obsolete generated indexes as well as removing their parent links:
  -- users can open an account or year ledger directly.
  let old = managedIncludeFiles importRoot (filter (Path.isProperPrefixOf stopAt) inventory)
  mapM_ (clearObsolete current) old
  _ <- writeFileMap opts ch (includes, indexes)
  return [base Path.</> f | f <- Map.keys groups, Path.parent f == boundary]
  where
    clearObsolete current file = unless (Map.member (Path.toFilePath file) current) $ do
      contents <- T.readFile (Path.toFilePath file)
      if includePreamble `T.isPrefixOf` contents
        then do
          _ <- writeFiles' (Map.singleton (Path.toFilePath file) (includePreamble <> "\n"))
          return ()
        else return ()

writeToplevelAllYearsInclude :: (HasBaseDir o, HasVerbosity o) => o -> IO [FilePath]
writeToplevelAllYearsInclude opts = do
  let directives = directivesFile opts
  directivesExists <- PathIO.doesFileExist directives
  let preMap = if directivesExists then Map.singleton (turtleBaseDir opts </> allYearsFileName) [Path.toFilePath directives] else Map.empty
  let allTop = Map.singleton (turtleBaseDir opts </> allYearsFileName) ["import" </> allYearsFileName]
  writeFiles' $ (addPreamble . toIncludeFiles' preMap Map.empty) allTop

extraIncludes :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> [FilePath] -> [T.Text] -> [FilePath] -> [FilePath] -> IO TurtleFileBundle
extraIncludes opts ch = extraIncludes' opts ch Map.empty

extraIncludes' :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> TurtleFileBundle -> [FilePath] -> [T.Text] -> [FilePath] -> [FilePath] -> IO TurtleFileBundle
extraIncludes' _ _ acc [] _ _ _ = return acc
extraIncludes' opts ch acc (file : files) extraSuffixes manualFiles prices = do
  extra <- extraIncludesForFile opts ch file extraSuffixes manualFiles prices
  extraIncludes' opts ch (Map.unionWith (++) acc extra) files extraSuffixes manualFiles prices

extraIncludesForFile :: (HasVerbosity o, HasBaseDir o) => o -> TChan LogMessage -> FilePath -> [T.Text] -> [FilePath] -> [FilePath] -> IO TurtleFileBundle
extraIncludesForFile opts ch file extraSuffixes manualFiles prices = do
  let name = FilePath.takeFileName file
      stem = if "." `List.isPrefixOf` name then name else FilePath.dropExtensions name
      dirprefix = takeWhile (/= '-') stem
      fileNames = [dirprefix ++ "-" ++ T.unpack suffix | suffix <- extraSuffixes]
  let suffixFiles = map (FilePath.takeDirectory file </>) fileNames
  let suffixDirFiles = map (((FilePath.takeDirectory file </> "_manual_") </> dirprefix) </>) manualFiles
  let priceFiles = map ((((FilePath.takeDirectory file </> "..") </> "prices") </> dirprefix) </>) prices
  let extraFiles = suffixFiles ++ suffixDirFiles ++ priceFiles
  filtered <- filterPaths doesFileExist extraFiles
  let logMsg =
        "Looking for possible extra include files for '" <> T.pack (relativeToBase opts file)
          <> "' among these " <> T.pack (show (length extraFiles)) <> " options: "
          <> T.pack (show (relativeFilesAsText opts extraFiles))
          <> ". Found " <> T.pack (show (length filtered)) <> ": "
          <> T.pack (show (relativeFilesAsText opts filtered))
  logVerbose opts ch logMsg
  return $ Map.fromList [(file, filtered)]

relativeFilesAsText :: (HasBaseDir o) => o -> [FilePath] -> [T.Text]
relativeFilesAsText opts = map (T.pack . relativeToBase opts)