swarm/app/Main.hs

{-# 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