potrero/src/Main.hs

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