refactor(grfn/xanthous): avoid unnecessary recompilation r/2850

hpack is a bit dumb when generating the list of modules for a cabal
file's component if multiple of them live in the same directory.
Specifically it seems to assume that all modules in the source-dirs
of a particular component are also necessary for its compilation.

This is quite bad in the case of xanthous since both library and
executable have source-dirs: src, so all modules will be compiled
twice: Once for the library and then again for the executable
despite it depending on the library (actually 4 times in total
since we need to build a unprofiled and profiled object for each
module…).

To fix this we just move Main.hs into its own directory and change
the executable's source-dirs, so hpack doesn't get confused anymore.
Since all components now have their own source-dirs, unnecessary
redundant compilation should be down to 0. The diff of the cabal
file shows quite nicely how many module recompilation we've gotten
rid of.

Change-Id: I2df4fab9b0299b3a2b5d3005508c79b2d9796039
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3533
Tested-by: BuildkiteCI
Reviewed-by: tazjin <mail@tazj.in>
Reviewed-by: grfn <grfn@gws.fyi>

1 files changed, 159 insertions, 0 deletions

diff --git a/users/grfn/xanthous/app/Main.hs b/users/grfn/xanthous/app/Main.hs
new file mode 100644
index 000000000000..6d88405fd9e0
--- /dev/null
+++ b/users/grfn/xanthous/app/Main.hs
@@ -0,0 +1,159 @@
+module Main ( main ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (finally)
+import           Brick
+import qualified Brick.BChan
+import qualified Graphics.Vty as Vty
+import qualified Options.Applicative as Opt
+import           System.Random
+import           Control.Monad.Random (getRandom)
+import           Control.Exception (finally)
+import           System.Exit (die)
+--------------------------------------------------------------------------------
+import qualified Xanthous.Game as Game
+import           Xanthous.Game.Env (GameEnv(..))
+import           Xanthous.App
+import           Xanthous.Generators.Level
+                 ( GeneratorInput
+                 , parseGeneratorInput
+                 , generateFromInput
+                 , showCells
+                 )
+import qualified Xanthous.Entities.Character as Character
+import           Xanthous.Generators.Level.Util (regions)
+import           Xanthous.Generators.Level.LevelContents
+import           Xanthous.Data (Dimensions, Dimensions'(Dimensions))
+import           Data.Array.IArray ( amap )
+--------------------------------------------------------------------------------
+
+data RunParams = RunParams
+  { seed :: Maybe Int
+  , characterName :: Maybe Text
+  }
+  deriving stock (Show, Eq)
+
+parseRunParams :: Opt.Parser RunParams
+parseRunParams = RunParams
+  <$> optional (Opt.option Opt.auto
+      ( Opt.long "seed"
+      <> Opt.help "Random seed for the game."
+      ))
+  <*> optional (Opt.strOption
+      ( Opt.short 'n'
+      <> Opt.long "name"
+      <> Opt.help
+        ( "Name for the character. If not set on the command line, "
+        <> "will be prompted for at runtime"
+        )
+      ))
+
+data Command
+  = Run RunParams
+  | Load FilePath
+  | Generate GeneratorInput Dimensions (Maybe Int)
+
+parseDimensions :: Opt.Parser Dimensions
+parseDimensions = Dimensions
+  <$> Opt.option Opt.auto
+       ( Opt.short 'w'
+       <> Opt.long "width"
+       <> Opt.metavar "TILES"
+       )
+  <*> Opt.option Opt.auto
+       ( Opt.short 'h'
+       <> Opt.long "height"
+       <> Opt.metavar "TILES"
+       )
+
+
+parseCommand :: Opt.Parser Command
+parseCommand = (<|> Run <$> parseRunParams) $ Opt.subparser
+  $ Opt.command "run"
+      (Opt.info
+       (Run <$> parseRunParams)
+       (Opt.progDesc "Run the game"))
+  <> Opt.command "load"
+      (Opt.info
+       (Load <$> Opt.argument Opt.str (Opt.metavar "FILE"))
+       (Opt.progDesc "Load a saved game"))
+  <> Opt.command "generate"
+      (Opt.info
+       (Generate
+        <$> parseGeneratorInput
+        <*> parseDimensions
+        <*> optional
+            (Opt.option Opt.auto (Opt.long "seed"))
+        <**> Opt.helper
+       )
+       (Opt.progDesc "Generate a sample level"))
+
+optParser :: Opt.ParserInfo Command
+optParser = Opt.info
+  (parseCommand <**> Opt.helper)
+  (Opt.header "Xanthous: a WIP TUI RPG")
+
+thanks :: IO ()
+thanks = putStr "\n\n" >> putStrLn "Thanks for playing Xanthous!"
+
+newGame :: RunParams -> IO ()
+newGame rparams = do
+  gameSeed <- maybe getRandom pure $ seed rparams
+  when (isNothing $ seed rparams)
+    . putStrLn
+    $ "Seed: " <> tshow gameSeed
+  let initialState = Game.initialStateFromSeed gameSeed &~ do
+        for_ (characterName rparams) $ \cn ->
+          Game.character . Character.characterName ?= cn
+  runGame NewGame initialState `finally` do
+    thanks
+    when (isNothing $ seed rparams)
+      . putStrLn
+      $ "Seed: " <> tshow gameSeed
+    putStr "\n\n"
+
+loadGame :: FilePath -> IO ()
+loadGame saveFile = do
+  gameState <- maybe (die "Invalid save file!") pure
+              =<< Game.loadGame . fromStrict <$> readFile @IO saveFile
+  gameState `deepseq` runGame LoadGame gameState
+
+runGame :: RunType -> Game.GameState -> IO ()
+runGame rt gameState = do
+  eventChan <- Brick.BChan.newBChan 10
+  let gameEnv = GameEnv eventChan
+  app <- makeApp gameEnv rt
+  let buildVty = Vty.mkVty Vty.defaultConfig
+  initialVty <- buildVty
+  _game' <- customMain
+    initialVty
+    buildVty
+    (Just eventChan)
+    app
+    gameState
+  pure ()
+
+runGenerate :: GeneratorInput -> Dimensions -> Maybe Int -> IO ()
+runGenerate input dims mSeed = do
+  putStrLn "Generating..."
+  genSeed <- maybe getRandom pure mSeed
+  let randGen = mkStdGen genSeed
+      res = generateFromInput input dims randGen
+      rs = regions $ amap not res
+  when (isNothing mSeed)
+    . putStrLn
+    $ "Seed: " <> tshow genSeed
+  putStr "num regions: "
+  print $ length rs
+  putStr "region lengths: "
+  print $ length <$> rs
+  putStr "character position: "
+  print =<< chooseCharacterPosition res
+  putStrLn $ showCells res
+
+runCommand :: Command -> IO ()
+runCommand (Run runParams) = newGame runParams
+runCommand (Load saveFile) = loadGame saveFile
+runCommand (Generate input dims mSeed) = runGenerate input dims mSeed
+
+main :: IO ()
+main = runCommand =<< Opt.execParser optParser