{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TypeFamilies #-}
module Main where
import qualified Control.Exception as Exn
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 ->
(Types.rollTable tables t >>= showValueAndRolls)
`Exn.catch` handleBadTable
handleBadTable :: Types.BadTable -> IO ()
handleBadTable bt = do
let msg = Text.intercalate "\n" (Types.potreroMessage bt)
Text.putStr "\x1b[91m"
Text.putStr msg
Text.putStrLn "\x1b[39m"
-- | 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)