ImportHelpersTurtle.hs

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

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

import Control.Concurrent.STM (TChan)
import Control.Monad (filterM, 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')
import Hledger.Flow.Common (allYearsFileName, filterPaths, groupValuesBy, textFileNeedsUpdate, 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 = renderIncludeFiles (baseDir opts) (logVerbose opts ch)

renderIncludeFiles :: BaseDir -> (T.Text -> IO ()) -> TurtleFileBundle -> IO (Map.Map FilePath T.Text)
renderIncludeFiles base logMessage m = do
  let extras suffixes manual prices = Map.unions <$> mapM
        (\file -> findExtraIncludes base logMessage file suffixes manual prices) (Map.keys m)
  preMap <- extras ["opening.journal"] ["pre-import.journal"] []
  postMap <- extras ["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"

writeIncludesFromInventory :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> AbsDir -> [AbsFile] -> [AbsFile] -> IO [AbsFile]
writeIncludesFromInventory opts ch stopAt inventory journals = do
  (files, roots) <- expectedIncludes (baseDir opts) (logVerbose opts ch) stopAt inventory journals
  _ <- writeFiles' files
  return roots

-- | Check the same contents import would write, including obsolete generated indexes.
includesNeedUpdate :: BaseDir -> AbsDir -> [AbsFile] -> [AbsFile] -> IO Bool
includesNeedUpdate base root inventory journals = do
  (includes, _) <- expectedIncludes base (const (return ())) root inventory journals
  top <- toplevelAllYearsInclude base
  anyChanged (Map.toList (Map.union top includes))
  where
    anyChanged [] = return False
    anyChanged ((file, contents) : rest) = do
      changed <- textFileNeedsUpdate file contents
      if changed then return True else anyChanged rest

expectedIncludes :: BaseDir -> (T.Text -> IO ()) -> AbsDir -> [AbsFile] -> [AbsFile] -> IO (Map.Map FilePath T.Text, [AbsFile])
expectedIncludes base logMessage stopAt inventory journals = do
  let 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
      old = managedIncludeFiles importRoot (filter (Path.isProperPrefixOf stopAt) inventory)
  rendered <- renderIncludeFiles base logMessage includes
  let current = Map.union rendered ((addPreamble . toIncludeFiles' Map.empty Map.empty) indexes)
      emptyIndex = includePreamble <> "\n"
  -- Users may still open obsolete generated indexes directly. Leave hand-written files alone.
  obsolete <- filterM (needsClearing emptyIndex) [file | file <- map Path.toFilePath old, Map.notMember file current]
  let files = Map.union current (Map.fromList [(file, emptyIndex) | file <- obsolete])
  return (files, [base Path.</> f | f <- Map.keys groups, Path.parent f == boundary])
  where
    needsClearing emptyIndex file = do
      text <- T.readFile file
      return (includePreamble `T.isPrefixOf` text && text /= emptyIndex)

writeToplevelAllYearsInclude :: (HasBaseDir o, HasVerbosity o) => o -> IO [FilePath]
writeToplevelAllYearsInclude opts = toplevelAllYearsInclude (baseDir opts) >>= writeFiles'

toplevelAllYearsInclude :: BaseDir -> IO (Map.Map FilePath T.Text)
toplevelAllYearsInclude base = do
  let directives = base Path.</> [Path.relfile|directives.journal|]
      top = Path.toFilePath base </> allYearsFileName
  directivesExists <- PathIO.doesFileExist directives
  let preMap = if directivesExists then Map.singleton top [Path.toFilePath directives] else Map.empty
      allTop = Map.singleton top ["import" </> allYearsFileName]
  return $ (addPreamble . toIncludeFiles' preMap Map.empty) allTop

extraIncludesForFile :: (HasVerbosity o, HasBaseDir o) => o -> TChan LogMessage -> FilePath -> [T.Text] -> [FilePath] -> [FilePath] -> IO TurtleFileBundle
extraIncludesForFile opts ch = findExtraIncludes (baseDir opts) (logVerbose opts ch)

findExtraIncludes :: BaseDir -> (T.Text -> IO ()) -> FilePath -> [T.Text] -> [FilePath] -> [FilePath] -> IO TurtleFileBundle
findExtraIncludes base logMessage 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 relative = relativeToBase' (Path.toFilePath base)
      logMsg =
        "Looking for possible extra include files for '" <> T.pack (relative file)
          <> "' among these " <> T.pack (show (length extraFiles)) <> " options: "
          <> T.pack (show (map (T.pack . relative) extraFiles))
          <> ". Found " <> T.pack (show (length filtered)) <> ": "
          <> T.pack (show (map (T.pack . relative) filtered))
  logMessage logMsg
  return $ Map.fromList [(file, filtered)]