CLI.hs

{-# OPTIONS_GHC -fno-warn-tabs #-}  -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces .
-- Enable warnings:
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

-- CLI.hs.

{-# LANGUAGE Haskell2010 #-}

module Immutaball.Ball.CLI
	(
		main,
		immutaballMain,
		immutaballCLIMain',
		immutaballCLIMain,
		mainImmutaballIO',
		mainImmutaballIO,
		immutaballOptions,
		immutaballWithArgs,
		immutaballHelp,
		immutaballHelp',
		immutaballIntroText,
		immutaballVersion,
		immutaballWithCLIConfig,
		cliIBDirs,
		getDefaultIBDirs,
		immutaballWithCLIConfig',
		immutaballWithNeverballrc,
		immutaballWithContext,
		initialImmutaball,
		defaultInitialImmutaball
	) where

-- Prelude imports
import Prelude ()
import Immutaball.Prelude

-- base imports
import Control.Arrow
import Data.List
import System.Console.GetOpt
import Text.Printf

-- external imports
import Control.Lens
import Control.Wire.Meta (isFallbackWire)
import qualified Data.Text as T
import System.FilePath

-- internal imports
import Immutaball.Ball.CLI.Config
import Immutaball.Ball.State.Title
import Immutaball.Share.Config
import Immutaball.Share.Config.Parser
import Immutaball.Share.Config.Printer
import Immutaball.Share.Context
import Immutaball.Share.Context.Config
import Immutaball.Share.Controller
import Immutaball.Share.ImmutaballIO
import Immutaball.Share.ImmutaballIO.BasicIO
import Immutaball.Share.State
import Immutaball.Share.Utils

main :: IO ()
main = immutaballMain

immutaballMain :: IO ()
immutaballMain = immutaballCLIMain'

immutaballCLIMain' :: IO ()
immutaballCLIMain' = immutaballCLIMain defaultStaticConfig

immutaballCLIMain :: StaticConfig -> IO ()
immutaballCLIMain x'cfg = do
	runImmutaballIO (mainImmutaballIO x'cfg)

mainImmutaballIO' :: ImmutaballIO
mainImmutaballIO' = mainImmutaballIO defaultStaticConfig

mainImmutaballIO :: StaticConfig -> ImmutaballIO
mainImmutaballIO x'cfg =
	mkBIO . GetArgsSync $ immutaballWithArgs x'cfg

immutaballOptions :: [OptDescr CLIConfigBuilder]
immutaballOptions =
	[
		Option ['H', '?'] ["help"]       (NoArg . b $ cliCfgHelp    .~ True)
			"Show help and exit",
		Option []         ["no-help"]    (NoArg . b $ cliCfgHelp    .~ False)
			"",
		Option ['V']      ["version"]    (NoArg . b $ cliCfgVersion .~ True)
			"Show version and exit",
		Option []         ["no-version"] (NoArg . b $ cliCfgVersion .~ False)
			"",

		Option ['d'] ["static-data-dir", "data"] (ReqArg (\path -> b $ cliCfgStaticDataDir .~ Just path) "")
			"Set static data directory path",
		Option []    ["user-data-dir"]           (ReqArg (\path -> b $ cliCfgUserDataDir   .~ Just path) "")
			"Set user data directory path",
		Option []    ["user-config-dir"]         (ReqArg (\path -> b $ cliCfgUserConfigDir .~ Just path) "")
			"Set user config directory path",

		Option [] ["no-static-data-dir"] (NoArg . b $ cliCfgStaticDataDir .~ Nothing)
			"",
		Option [] ["no-user-data-dir"]   (NoArg . b $ cliCfgUserDataDir   .~ Nothing)
			"",
		Option [] ["no-user-config-dir"] (NoArg . b $ cliCfgUserConfigDir .~ Nothing)
			"",

		Option [] ["headless"] (NoArg . b $ cliCfgHeadless .~ True)
			"",
		Option [] ["no-headless"] (NoArg . b $ cliCfgHeadless .~ False)
			"",

		Option ['Q'] ["skip-intro-text"] (NoArg . b $ cliCfgSkipIntroText .~ True)
			"",
		Option [] ["no-skip-intro-text"] (NoArg . b $ cliCfgSkipIntroText .~ False)
			"",

		Option [] ["help-detailed"] (NoArg . b $ cliCfgHelpDetailed .~ True)
			"",
		Option [] ["no-help-detailed"] (NoArg . b $ cliCfgHelpDetailed .~ False)
			"",

		Option [] ["request-override-physics"] (ReqArg (\str -> b $ cliCfgOverridePhysics .~ Just (Just str)) "")
			"",
		Option [] ["no-request-override-physics"] (NoArg . b $ cliCfgOverridePhysics .~ Nothing)
			""
	]
	where b = CLIConfigBuilder

immutaballWithArgs :: StaticConfig -> [String] -> ImmutaballIO
immutaballWithArgs x'cfg args =
	result
	where
		opts :: [CLIConfigBuilder]
		nonopts, errs :: [String]
		(opts, nonopts, errs) = getOpt Permute immutaballOptions args
		cliCfg = buildCLIConfig (mconcat opts)
		showErrs :: [String] -> ImmutaballIO
		showErrs errs_ = foldr (<>>) mempty $ showErr <$> errs_
		showErr :: String -> ImmutaballIO
		showErr errMsg = mkBIO . PutStrLn (printf "Error: CLI getOpt error: %s" errMsg) $ mkBIO ExitFailureBasicIOF
		result :: ImmutaballIO
		result
			| (not . null) errs    = showErrs errs <>> mkBIO ExitFailureBasicIOF
			| (not . null) nonopts = showErrs $ map (\nonopt -> printf "nonoptions currently not supported; received nonoption ‘%s’" nonopt) nonopts
			| otherwise            = immutaballWithCLIConfig x'cfg cliCfg

immutaballHelp :: String
immutaballHelp = immutaballHelp' False

immutaballHelp' :: Bool -> String
immutaballHelp' detailed = intercalate "\n" $
	[
		"Usage: immutaball [options…]",
		"",
		"Options:",
		"\t--help: Show usage and exit.",
		"\t--version: Show version and exit.",
		"\t-d PATH, --data PATH, --static-data-dir PATH:",
		"\t\tSet static data directory path.",
		"\t--user-data-dir PATH:",
		"\t\tSet user data directory path.",
		"\t--user-config-dir PATH:",
		"\t\tSet user config directory path.",
		"\t--headless:",
		"\t\tDisable video and audio.  Useful for automated testing.",
		"\t-Q, --skip-intro-text:",
		"\t\tSilence the intro text on startup.",
		"\t--help-detailed:",
		"\t\tShow additional usage and exit."
	] ++ if' (not detailed) []
	[
		"",
		"Additional options:",
		"\t--request-override-physics=default:",
		"\t\tFor debugging or development, select the default physics algorithm.",
		"\t--request-override-physics=stationary:",
		"\t\tFor debugging or development, select the stationary physics algorithm.",
		"\t--request-override-physics=ghostly:",
		"\t\tFor debugging or development, select the ghostly physics algorithm.",
		"\t--request-override-physics=brute-force:",
		"\t\tFor debugging or development, select the brute-force physics algorithm.",
		"\t\tWARNING: does not perform well on large levels and may freeze!",
		"\t--request-override-physics=bsp:",
		"\t\tFor debugging or development, select the bsp physics algorithm."
	]

immutaballIntroText :: String
immutaballIntroText = intercalate "\n" $
	[
		"Welcome to Immutaball v" ++ immutaballVersion ++ "!",
		"",
		"WARNING: This prototype version currently only implements",
		"         basic functionality; much of the game is yet unimplemented.",
		"         A basic GUI, renderer, and physics is currently supported.",
		"         Currently, the physics does not fully support moving bodies,",
		"         and currently seems to have a few bugs.",
		"",
		"To use Immutaball, you'll need to build Neverball and call Immutaball",
		"with the path to the data dir in the Neverball build:",
		"\tcd ~/git",
		"\tgit clone https://github.com/Neverball/neverball",
		"\tcd ~/git/neverball",
		"\t# git checkout 1.7.0-alpha.3  # Optionally check out the most recent version known to be supported if there are issues.",
		"\tmake -j7",
		"",
		"\tcd ~/git",
		"\tgit clone https://github.com/nibzdil/immutaball",
		"\tcd ~/git/immutaball",
		"\tcabal build --enable-tests",
		"\tcabal run immutaball -- -d ~/git/neverball/data",
		"",
		"Alternatively, if there is a system-installed Neverball package",
		"already built, you can also use its data path instead when passing",
		"‘-d PATH’.",
		""
	] ++
	(if' (not isFallbackWire)
		[
			"Using external dependency ‘wires’ (not fallback implementation)."
		]
		[
			"Not using external package ‘wires’ for dependency",
			"(perhaps it failed to build); using fallback implementation",
			"(performance not necessarily optimized)."
		]
	) ++
	[
		"",
		"Pass ‘--help’ for usage information.",
		"Pass ‘-Q’ to silence this intro text."
	]

immutaballVersion :: String
immutaballVersion = "0.1.0.5.1-hackage"

-- | Run immutaball.
immutaballWithCLIConfig :: StaticConfig -> CLIConfig -> ImmutaballIO
immutaballWithCLIConfig x'cfg cliCfg =
	result
	where
		showHelp :: ImmutaballIO
		showHelp = mkBIO . PutStrLn immutaballHelp $ mkBIO ExitSuccessBasicIOF
		showHelp' :: Bool -> ImmutaballIO
		showHelp' detailed = mkBIO . PutStrLn (immutaballHelp' detailed) $ mkBIO ExitSuccessBasicIOF
		showVersion :: ImmutaballIO
		showVersion = mkBIO . PutStrLn immutaballVersion $ mkBIO ExitSuccessBasicIOF
		showIntroTextThen :: ImmutaballIO -> ImmutaballIO
		showIntroTextThen
			| null immutaballIntroText      = id
			| (cliCfg^.cliCfgSkipIntroText) = id
			| otherwise =
				mkBIO . PutStrLn immutaballIntroText
		-- Allow CLI options to update the static config.
		x'cfg' :: StaticConfig
		x'cfg'
			| Just val <- cliCfg^.cliCfgOverridePhysics = x'cfg & x'cfgRequestAlternativePhysics .~ val
			| otherwise = x'cfg
		result :: ImmutaballIO
		result
			| cliCfg^.cliCfgHelpDetailed = showHelp' True
			| cliCfg^.cliCfgHelp         = showHelp
			| cliCfg^.cliCfgVersion      = showVersion
			| otherwise                  = showIntroTextThen $ immutaballWithCLIConfig' x'cfg' cliCfg

cliIBDirs :: CLIConfig -> IBDirs -> IBDirs
cliIBDirs cliCfg defaultIBDirs = IBDirs {
	_ibStaticDataDir = maybe (defaultIBDirs^.ibStaticDataDir) id (cliCfg^.cliCfgStaticDataDir),
	_ibUserDataDir   = maybe (defaultIBDirs^.ibUserDataDir)   id (cliCfg^.cliCfgUserDataDir),
	_ibUserConfigDir = maybe (defaultIBDirs^.ibUserConfigDir) id (cliCfg^.cliCfgUserConfigDir)
}

getDefaultIBDirs :: StaticConfig -> (IBDirs -> ImmutaballIO) -> ImmutaballIO
getDefaultIBDirs x'cfg withIBDirs =
	either (\d f -> mkBIO . DirectoryIO . fmap f $ d) (&) (x'cfg^.defaultStaticDataDir) $ \defaultStaticDataDir_ ->
	either (\d f -> mkBIO . DirectoryIO . fmap f $ d) (&) (x'cfg^.defaultUserDataDir)   $ \defaultUserDataDir_ ->
	either (\d f -> mkBIO . DirectoryIO . fmap f $ d) (&) (x'cfg^.defaultUserConfigDir) $ \defaultUserConfigDir_ ->
	withIBDirs $ IBDirs {
		_ibStaticDataDir = defaultStaticDataDir_,
		_ibUserDataDir   = defaultUserDataDir_,
		_ibUserConfigDir = defaultUserConfigDir_
	}

-- | Run immutaball after basic setup like checking for ‘--help’.
immutaballWithCLIConfig' :: StaticConfig -> CLIConfig -> ImmutaballIO
immutaballWithCLIConfig' x'cfg cliCfg =
	result
	where
		result :: ImmutaballIO
		result = getDefaultIBDirs x'cfg withDefaultIBDirs
		withDefaultIBDirs :: IBDirs -> ImmutaballIO
		withDefaultIBDirs defaultIBDirs = result_
			where
				result_ :: ImmutaballIO
				result_ = createUserDirsIfMissing <>> (mkBIO . DoesPathExistSync neverballrcPath $ withNeverballrcExists)
				createUserDirsIfMissing :: ImmutaballIO
				createUserDirsIfMissing = mconcat . map (mkBIO . flip CreateDirectoryIfMissing mempty) $ [ibDirs_^.ibUserDataDir, ibDirs_^.ibUserConfigDir]
				ibDirs_ :: IBDirs
				ibDirs_ = cliIBDirs cliCfg defaultIBDirs
				neverballrcPath :: FilePath
				neverballrcPath = (ibDirs_^.ibUserConfigDir) </> (x'cfg^.configFilename)
				writeDefaultNeverballrc :: ImmutaballIO
				writeDefaultNeverballrc = mkBIO $ WriteText neverballrcPath (T.pack . showNeverballrc $ defaultNeverballrc) mempty
				defaultNeverballrc :: Neverballrc
				defaultNeverballrc = defaultConfig
				withNeverballrcExists :: Bool -> ImmutaballIO
				withNeverballrcExists False = writeDefaultNeverballrc <>> withNeverballrcExists True
				withNeverballrcExists True = result_2
					where
						result_2 :: ImmutaballIO
						result_2 = mkBIO . ReadTextSync neverballrcPath . (mkThrowIO |||) $ \neverballrcContents -> withParse $ parseNeverballrc neverballrcPath (T.unpack neverballrcContents)
						withParse :: Either String Neverballrc -> ImmutaballIO
						withParse (Left  parseError)   = mkBIO . PutStrLn (printf "Error: failed to parse neverballrc: %s" parseError) $ mkBIO ExitFailureBasicIOF
						withParse (Right neverballrc_) = immutaballWithNeverballrc x'cfg cliCfg ibDirs_ neverballrc_

--- | Run immutaball after getting neverballrc and dirs.
immutaballWithNeverballrc :: StaticConfig -> CLIConfig -> IBDirs -> Neverballrc -> ImmutaballIO
immutaballWithNeverballrc x'cfg cliCfg ibDirs_ nrcCfg =
	result
	where
		result :: ImmutaballIO
		result = withSDL cxtCfg immutaballWithContext
		cxtCfg :: ContextConfig
		cxtCfg = ContextConfig {
			_cxtCfgStaticConfig = x'cfg,
			_cxtCfgDirs         = ibDirs_,
			_cxtCfgNeverballrc  = nrcCfg,
			_cxtCfgInitialWire  = joinMaybeResult $ (x'cfg^.x'cfgInitialWireWithCxt),
			_cxtCfgHeadless     = (cliCfg^.cliCfgHeadless),

			_cxtCfgUseExistingSDLManager = (x'cfg^.x'cfgUseExistingSDLManager),
			_cxtCfgUseExistingGLManager  = (x'cfg^.x'cfgUseExistingGLManager)
		}

--- | Run immutaball after setting up an initial immutaball context.
immutaballWithContext :: IBContext -> ImmutaballIO
immutaballWithContext cxt0 =
	result
	where
		result :: ImmutaballIO
		result = controlImmutaball cxt0 (initialImmutaball cxt0)

initialImmutaball :: IBContext -> Immutaball
initialImmutaball cxt0 = maybe (defaultInitialImmutaball cxt0) id $ (cxt0^.ibInitialWire) cxt0

defaultInitialImmutaball :: IBContext -> Immutaball
defaultInitialImmutaball cxt0 = mkTitleState (Left cxt0)