12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697 |
- {-# LANGUAGE OverloadedStrings #-}
- {-# LANGUAGE OverloadedLists #-}
- {-# LANGUAGE TypeFamilies #-}
- module Main where
- import qualified Control.Monad as M
- import qualified Data.IORef as IO
- import qualified Data.Map.Strict as Map
- import Data.Monoid ((<>))
- import qualified Data.Text as Text
- import qualified Data.Text.IO as Text
- import qualified System.Console.Readline as Readline
- import qualified System.Environment as Env
- import qualified System.Exit as Exit
- import qualified Parser
- import qualified Types
- readMap :: FilePath -> IO Types.TableMap
- readMap path = do
- cs <- Text.readFile path
- pure $ Map.fromList
- [ (Types.tableName t, t)
- | t <- Parser.parseTable cs
- ]
- main :: IO ()
- main = do
- args <- Env.getArgs
- let filename = case args of
- path:_ -> path
- _ -> "perilous-wilds.txt"
- tablesRef <- IO.newIORef =<< readMap filename
- Readline.setCompletionEntryFunction $ Just $ \ rs -> do
- tables <- IO.readIORef tablesRef
- pure [ Text.unpack k
- | k <- Map.keys tables
- , Text.pack rs `Text.isPrefixOf` k
- ]
- M.forever $ do
- input <- Readline.readline "\x1b[31m--> \x1b[39m"
- case input of
- Nothing -> do
- putStrLn "farewell"
- Exit.exitSuccess
- Just ":q" -> do
- putStrLn "farewell"
- Exit.exitSuccess
- Just "" -> pure ()
- Just ":l" -> do
- tables <- IO.readIORef tablesRef
- Text.putStrLn "Available tables: "
- Text.putStrLn (" " <> Text.unwords (Map.keys tables))
- Just ":r" ->
- IO.writeIORef tablesRef =<< readMap filename
- Just choice -> do
- tables <- IO.readIORef tablesRef
- let names = Text.unwords (Map.keys tables)
- Readline.addHistory choice
- case Map.lookup (Text.strip (Text.pack choice)) tables of
- Nothing -> do
- Text.putStrLn ("table not found: " <> Text.pack (show choice))
- Text.putStrLn (" valid tables include: " <> names)
- Just t -> do
- v <- Types.rollTable tables t
- showValueAndRolls v
- -- | simply show the value generated
- showValue :: Types.Value -> IO ()
- showValue value = Text.putStrLn (Types.valueMsg value)
- -- | pretty-print the value as well as each roll that was done on an
- -- intermediate table
- showValueAndRolls :: Types.Value -> IO ()
- showValueAndRolls value = go 0 value
- where
- go n v
- | Text.null (Text.strip (Types.valueMsg v)) = pure ()
- | otherwise = do
- Text.putStr "\x1b[36m"
- Text.putStr (Text.replicate (n+1) " ")
- putStr (show (Types.valueResult v))
- Text.putStr " on "
- Text.putStr (Types.valueFrom v)
- M.when (null (Types.valueSources v)) $ do
- Text.putStr ": \""
- Text.putStr (Text.strip (Types.valueMsg v))
- Text.putStr "\""
- Text.putStrLn "\x1b[39m"
- mapM_ (go (n+1)) (Types.valueSources v)
- M.when (n == 0) $
- Text.putStrLn (Types.valueMsg v)
|