potrero/src/Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TypeFamilies #-}

module Main (main) where

import qualified Control.Exception as Exn
import qualified Control.Monad as M
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 Potrero.Opts as Opts
import qualified Potrero.Parser as Parser
import qualified Potrero.Types as 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
  case Opts.getConfig args of
    Left err -> do
      putStrLn err
      putStrLn Opts.usage
      Exit.exitFailure
    Right config
      | Opts.configMode config == Opts.ShowHelp ->
        putStrLn Opts.usage
      | Opts.configMode config == Opts.ShowVersion ->
        putStrLn Opts.version
      | otherwise -> do
        maps <- mapM readMap (Opts.configFiles config)
        runRepl (Map.unions maps) config

setCompletion :: Types.TableMap -> IO ()
setCompletion tables =
  Readline.setCompletionEntryFunction $ Just $ \rs ->
  pure [ Text.unpack k
       | k <- Map.keys tables
       , Text.pack rs `Text.isPrefixOf` k
       ]

runRepl :: Types.TableMap -> Opts.Config -> IO ()
runRepl tables config = do
  setCompletion tables
  let printFunc = case Opts.configShowRolls config of
        False -> showValue
        True  -> showValueAndRolls

  input <- Readline.readline "\x1b[31m--> \x1b[39m"
  case input of
    Nothing -> do
      putStrLn "farewell"
      Exit.exitSuccess
    Just ":q" -> do
      putStrLn "farewell"
      Exit.exitSuccess

    Just "" -> runRepl tables config

    Just ":l" -> do
      Text.putStrLn "Available tables: "
      Text.putStrLn ("  " <> Text.unwords (Map.keys tables))
      runRepl tables config

    Just ":r" -> do
      maps <- mapM readMap (Opts.configFiles config)
      putStrLn ("reloaded: " <> unwords (Opts.configFiles config))
      runRepl (Map.unions maps) config

    Just choice -> do
      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 >>= printFunc)
          `Exn.catch` handleBadTable
      runRepl tables config

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)