App.hs

module Engine.App
  ( engineMain
  , engineMainWith
  , withDataDir
  , withDefaultArgs
  ) where

import RIO hiding (traceM)

import Debug.Trace (traceM)
import Engine.Run (runStack)
import Engine.Setup (setup)
import Engine.Stage.Bootstrap.Setup qualified as Bootstrap
import Engine.Types qualified as Engine
import Engine.Types.Options (Options(..), getOptions)
import RIO.App (appMain)
import RIO.Directory (doesDirectoryExist, getCurrentDirectory, withCurrentDirectory)
import RIO.FilePath (takeDirectory, takeFileName, (</>))
import RIO.List (find, isPrefixOf)
import System.Environment (getArgs, getExecutablePath, withArgs)

engineMain :: Engine.StackStage -> IO ()
engineMain initialStage = engineMainWith (\() -> initialStage) (pure ())

engineMainWith :: (a -> Engine.StackStage) -> Engine.StageSetupRIO a -> IO ()
engineMainWith handoff action =
  appMain getOptions optionsVerbose setup $ runStack
    [ -- XXX: run swapchain bootstrap and replace with next stage
      Bootstrap.stackStage handoff action
    ]

withDataDir :: IO FilePath -> FilePath -> IO a -> IO a
withDataDir getDataDir name action = do
  currentDir <- getCurrentDirectory

  executableDir <- fmap takeDirectory getExecutablePath
  let shareDir = takeDirectory executableDir </> "share"

  usrShareName <- fmap takeFileName getDataDir
  let
    withVer = usrShareName
    sansVer = stripVersion withVer

  let
    candidates =
      [ currentDir
      , shareDir </> withVer
      , shareDir </> sansVer
      ]
  exists <- for candidates \dir ->
    doesDirectoryExist (dir </> name)
  case filter fst (zip exists candidates) of
    (True, found) : _rest ->
      withCurrentDirectory found $
        action
    _ -> do
      traceM "Data directory not found:"
      traverse_ traceM candidates
      exitFailure
  where
    stripVersion = reverse . drop 1 . dropWhile (/= '-') . reverse

withDefaultArgs :: [(String, Maybe String)] -> IO a -> IO a
withDefaultArgs defaults action = do
  args <- getArgs
  withArgs (injectArgs args defaults) action

injectArgs :: [String] -> [(String, Maybe String)] -> [String]
injectArgs provided = foldr inject provided
  where
    inject (name, mvalue) acc =
      case find (name `isPrefixOf`) provided of
        Just _overriden ->
          acc
        Nothing ->
          name : maybeToList mvalue <> acc