Launcher.hs

module YMonad.Launcher (
  launcherMain,
) where

import Data.Time.Clock (UTCTime)
import System.Directory
import System.Environment (getEnvironment, getExecutablePath)
import System.Exit (ExitCode (..))
import System.FilePath (takeDirectory, (</>))
import System.Process

import YMonad

launcherMain :: IO ()
launcherMain = do
  configPath <- getConfigPath
  configExists <- doesFileExist configPath
  if not configExists
    then ymonad def
    else do
      cacheDir <- getCacheDirectory
      createDirectoryIfMissing True cacheDir
      let buildDir = cacheDir </> "build"
          binaryPath = cacheDir </> "ymonad-config"
          errorPath = cacheDir </> "ymonad.errors"
      forceRebuild <- fmap isJust (lookupEnv "YMONAD_FORCE_REBUILD")
      shouldBuild <- if forceRebuild then pure True else shouldRebuildConfig configPath binaryPath
      when shouldBuild $ recompileConfig configPath buildDir binaryPath errorPath
      launchCompiledConfig binaryPath

getConfigPath :: IO FilePath
getConfigPath = do
  explicit <- lookupEnv "YMONAD_CONFIG"
  case explicit of
    Just path -> pure path
    Nothing -> do
      configHome <- lookupEnv "XDG_CONFIG_HOME"
      case configHome of
        Just dir -> pure (dir </> "ymonad" </> "ymonad.hs")
        Nothing -> do
          homeDir <- getHomeDirectory
          pure (homeDir </> ".config" </> "ymonad" </> "ymonad.hs")

getCacheDirectory :: IO FilePath
getCacheDirectory = do
  cacheHome <- lookupEnv "XDG_CACHE_HOME"
  case cacheHome of
    Just dir -> pure (dir </> "ymonad")
    Nothing -> do
      homeDir <- getHomeDirectory
      pure (homeDir </> ".cache" </> "ymonad")

shouldRebuildConfig :: FilePath -> FilePath -> IO Bool
shouldRebuildConfig configPath binaryPath = do
  binaryExists <- doesFileExist binaryPath
  if not binaryExists
    then pure True
    else do
      configTime <- getModificationTime configPath
      binaryTime <- getModificationTime binaryPath
      libTime <- newestLibraryTimestamp (takeDirectory configPath </> "lib")
      pure (configTime > binaryTime || maybe False (> binaryTime) libTime)

newestLibraryTimestamp :: FilePath -> IO (Maybe UTCTime)
newestLibraryTimestamp root = do
  exists <- doesDirectoryExist root
  if not exists
    then pure Nothing
    else do
      files <- listFilesRecursive root
      case files of
        [] -> pure Nothing
        firstFile : otherFiles -> do
          firstTime <- getModificationTime firstFile
          otherTimes <- mapM getModificationTime otherFiles
          pure (Just (foldl' max firstTime otherTimes))

listFilesRecursive :: FilePath -> IO [FilePath]
listFilesRecursive root = do
  names <- listDirectory root
  fmap concat . forM names $ \name -> do
    let path = root </> name
    isDir <- doesDirectoryExist path
    if isDir
      then listFilesRecursive path
      else pure [path]

recompileConfig :: FilePath -> FilePath -> FilePath -> FilePath -> IO ()
recompileConfig configPath buildDir binaryPath errorPath = do
  createDirectoryIfMissing True buildDir
  ghcPath <- getCompilerPath
  let configDir = takeDirectory configPath
      libDir = configDir </> "lib"
      ghcArgs =
        [ "--make"
        , configPath
        , "-outputdir"
        , buildDir
        , "-o"
        , binaryPath
        , "-i" <> configDir
        , "-i" <> libDir
        , "-package"
        , "YMonad"
        ]
  (exitCode, stdoutText, stderrText) <- readProcessWithExitCode ghcPath ghcArgs ""
  let buildLog = stdoutText <> stderrText
  writeFile errorPath buildLog
  case exitCode of
    ExitSuccess -> pass
    ExitFailure exitCodeValue -> die ("Failed to compile " <> configPath <> " (exit code " <> show exitCodeValue <> "). See " <> errorPath)

getCompilerPath :: IO FilePath
getCompilerPath = do
  envPath <- lookupEnv "YMONAD_GHC"
  case envPath of
    Just path -> pure path
    Nothing -> do
      found <- findExecutable "ghc"
      case found of
        Just path -> pure path
        Nothing -> die "ghc was not found in PATH; set YMONAD_GHC or install ghc"

launchCompiledConfig :: FilePath -> IO ()
launchCompiledConfig binaryPath = do
  launcherPath <- getExecutablePath
  env0 <- getEnvironment
  let helperPath = takeDirectory launcherPath </> "ymonadctl"
      env1 =
        ("YMONAD_CTL_PATH", helperPath)
          : ("YMONAD_LAUNCHER_PATH", launcherPath)
          : filter (\(name, _value) -> name /= "YMONAD_CTL_PATH" && name /= "YMONAD_LAUNCHER_PATH") env0
  (_, _, _, ph) <- createProcess ((proc binaryPath []) {env = Just env1})
  waitForProcess ph >>= exitWith