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