mirror of
https://github.com/swarm-game/swarm.git
synced 2024-09-11 22:58:21 +03:00
Closes #1443. Also added `-Wunused-packages` to clean up dependencies. ## Demo This still works as usual: stack run Output editor keywords: stack run swarm-docs -- editors --emacs
180 lines
6.2 KiB
Haskell
180 lines
6.2 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
-- |
|
|
-- SPDX-License-Identifier: BSD-3-Clause
|
|
module Main where
|
|
|
|
import Data.Foldable qualified
|
|
import Data.Text (Text, pack)
|
|
import Data.Text.IO qualified as Text
|
|
import GitHash (GitInfo, giBranch, giHash, tGitInfoCwdTry)
|
|
import Options.Applicative
|
|
import Prettyprinter
|
|
import Prettyprinter.Render.Text qualified as RT
|
|
import Swarm.App (appMain)
|
|
import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..))
|
|
import Swarm.Game.World.Render (OuputFormat (..), RenderOpts (..), doRenderCmd)
|
|
import Swarm.Language.LSP (lspMain)
|
|
import Swarm.Language.Parse (readTerm)
|
|
import Swarm.Language.Pretty (ppr)
|
|
import Swarm.TUI.Model (AppOpts (..), ColorMode (..))
|
|
import Swarm.TUI.Model.UI (defaultInitLgTicksPerSecond)
|
|
import Swarm.Util ((?))
|
|
import Swarm.Version
|
|
import Swarm.Web (defaultPort)
|
|
import System.Console.Terminal.Size qualified as Term
|
|
import System.Exit (exitFailure)
|
|
import System.IO (hPrint, stderr)
|
|
import Text.Read (readMaybe)
|
|
|
|
gitInfo :: Maybe GitInfo
|
|
gitInfo = either (const Nothing) Just ($$tGitInfoCwdTry)
|
|
|
|
commitInfo :: String
|
|
commitInfo = case gitInfo of
|
|
Nothing -> ""
|
|
Just git -> " (" <> giBranch git <> "@" <> take 10 (giHash git) <> ")"
|
|
|
|
type Width = Int
|
|
|
|
data CLI
|
|
= Run AppOpts
|
|
| Format Input (Maybe Width)
|
|
| RenderMap FilePath RenderOpts
|
|
| LSP
|
|
| Version
|
|
|
|
cliParser :: Parser CLI
|
|
cliParser =
|
|
subparser
|
|
( mconcat
|
|
[ command "format" (info (Format <$> format <*> optional widthOpt <**> helper) (progDesc "Format a file"))
|
|
, command "map" (info (render <**> helper) (progDesc "Render a scenario world map."))
|
|
, command "lsp" (info (pure LSP) (progDesc "Start the LSP"))
|
|
, command "version" (info (pure Version) (progDesc "Get current and upstream version."))
|
|
]
|
|
)
|
|
<|> Run
|
|
<$> ( AppOpts
|
|
<$> seed
|
|
<*> scenario
|
|
<*> run
|
|
<*> autoplay
|
|
<*> speedFactor
|
|
<*> cheat
|
|
<*> color
|
|
<*> webPort
|
|
<*> pure gitInfo
|
|
)
|
|
where
|
|
render :: Parser CLI
|
|
render = RenderMap <$> strArgument (metavar "SCENARIO") <*> subOpts
|
|
where
|
|
sizeOpts =
|
|
AreaDimensions
|
|
<$> option auto (metavar "WIDTH" <> short 'w' <> long "width" <> help "width of source grid")
|
|
<*> option auto (metavar "HEIGHT" <> short 'h' <> long "height" <> help "height of source grid")
|
|
|
|
subOpts =
|
|
RenderOpts
|
|
<$> seed
|
|
<*> flag ConsoleText PngImage (long "png" <> help "Render to PNG")
|
|
<*> option str (long "dest" <> short 'd' <> value "output.png" <> help "Output filepath")
|
|
<*> optional sizeOpts
|
|
|
|
format :: Parser Input
|
|
format =
|
|
flag' Stdin (long "stdin" <> help "Read code from stdin")
|
|
<|> (File <$> strArgument (metavar "FILE"))
|
|
|
|
widthOpt :: Parser Width
|
|
widthOpt = option auto (long "width" <> metavar "COLUMNS" <> help "Use layout with maximum width")
|
|
|
|
seed :: Parser (Maybe Int)
|
|
seed = optional $ option auto (long "seed" <> short 's' <> metavar "INT" <> help "Seed to use for world generation")
|
|
webPort :: Parser (Maybe Int)
|
|
webPort =
|
|
optional $
|
|
option
|
|
auto
|
|
( long "web"
|
|
<> metavar "PORT"
|
|
<> help ("Set the web service port (or disable it with 0). Default to " <> show defaultPort <> ".")
|
|
)
|
|
scenario :: Parser (Maybe String)
|
|
scenario = optional $ strOption (long "scenario" <> short 'i' <> metavar "FILE" <> help "Name of an input scenario to load")
|
|
run :: Parser (Maybe String)
|
|
run = optional $ strOption (long "run" <> short 'r' <> metavar "FILE" <> help "Run the commands in a file at startup")
|
|
autoplay :: Parser Bool
|
|
autoplay = switch (long "autoplay" <> short 'a' <> help "Automatically run the solution defined in the scenario, if there is one. Mutually exclusive with --run.")
|
|
speedFactor :: Parser Int
|
|
speedFactor = option auto (long "speed" <> short 'm' <> value defaultInitLgTicksPerSecond <> help "Initial game speed multiplier")
|
|
cheat :: Parser Bool
|
|
cheat = switch (long "cheat" <> short 'x' <> help "Enable cheat mode. This allows toggling Creative Mode with Ctrl+v and unlocks \"Testing\" scenarios in the menu.")
|
|
color :: Parser (Maybe ColorMode)
|
|
color = optional $ option colorModeParser (long "color" <> short 'c' <> metavar "MODE" <> help "Use none/8/16/full color mode.")
|
|
colorModeParser =
|
|
Data.Foldable.asum
|
|
[ ColorMode8 <$ text "8"
|
|
, ColorMode16 <$ text "16"
|
|
, ColorMode240 <$> maybeReader (\case ('2' : '4' : '0' : '_' : w) -> readMaybe w; _ -> Nothing)
|
|
, FullColor <$ text "full"
|
|
, NoColor <$ text "none"
|
|
]
|
|
text t = maybeReader (\x -> if x == t then Just x else Nothing)
|
|
|
|
cliInfo :: ParserInfo CLI
|
|
cliInfo =
|
|
info
|
|
(cliParser <**> helper)
|
|
( header ("Swarm game - " <> version <> commitInfo)
|
|
<> progDesc "To play the game simply run without any command."
|
|
<> fullDesc
|
|
)
|
|
|
|
data Input = Stdin | File FilePath
|
|
|
|
getInput :: Input -> IO Text
|
|
getInput Stdin = Text.getContents
|
|
getInput (File fp) = Text.readFile fp
|
|
|
|
showInput :: Input -> Text
|
|
showInput Stdin = "(input)"
|
|
showInput (File fp) = pack fp
|
|
|
|
-- | Utility function to validate and format swarm-lang code
|
|
formatFile :: Input -> Maybe Width -> IO ()
|
|
formatFile input mWidth = do
|
|
content <- getInput input
|
|
case readTerm content of
|
|
Right Nothing -> Text.putStrLn ""
|
|
Right (Just ast) -> do
|
|
mWindow <- Term.size
|
|
let mkOpt w = LayoutOptions (AvailablePerLine w 1.0)
|
|
let opt =
|
|
fmap mkOpt mWidth
|
|
? fmap (\(Term.Window _h w) -> mkOpt w) mWindow
|
|
? defaultLayoutOptions
|
|
Text.putStrLn . RT.renderStrict . layoutPretty opt $ ppr ast
|
|
Left e -> do
|
|
Text.hPutStrLn stderr $ showInput input <> ":" <> e
|
|
exitFailure
|
|
|
|
showVersion :: IO ()
|
|
showVersion = do
|
|
putStrLn $ "Swarm game - " <> version <> commitInfo
|
|
up <- getNewerReleaseVersion gitInfo
|
|
either (hPrint stderr) (putStrLn . ("New upstream release: " <>)) up
|
|
|
|
main :: IO ()
|
|
main = do
|
|
cli <- execParser cliInfo
|
|
case cli of
|
|
Run opts -> appMain opts
|
|
Format fo w -> formatFile fo w
|
|
RenderMap mapPath opts -> doRenderCmd opts mapPath
|
|
LSP -> lspMain
|
|
Version -> showVersion
|