Add a Value type to try to keep track of roll history

src/Main.hs

@@ -11,6 +11,7 @@ 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
@@ -27,7 +28,11 @@ readMap path = do
 
 main :: IO ()
 main = do
-  tablesRef <- IO.newIORef =<< readMap "perilous-wilds.txt"
+  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
@@ -51,7 +56,7 @@ main = do
         Text.putStrLn "Available tables: "
         Text.putStrLn ("  " <> Text.unwords (Map.keys tables))
       Just ":r" ->
-        IO.writeIORef tablesRef =<< readMap "perilous-wilds.txt"
+        IO.writeIORef tablesRef =<< readMap filename
 
       Just choice -> do
         tables <- IO.readIORef tablesRef
@@ -61,4 +66,32 @@ main = do
           Nothing -> do
             Text.putStrLn ("table not found: " <> Text.pack (show choice))
             Text.putStrLn ("  valid tables include: " <> names)
-          Just t -> Types.rollTable tables t >>= (Text.putStrLn . Types.valueMsg)
+          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)

src/Types.hs

@@ -2,15 +2,18 @@
 
 module Types where
 
+import qualified Control.Exception as Exn
 import qualified Data.Map.Strict as Map
 import qualified Data.Text as Text
-import qualified Data.Text.IO as Text
 import qualified System.Random as Rand
 
-data Range = Range { rFrom :: Int, rTo :: Int }
+type TableName = Text.Text
+type Roll = Int
+
+data Range = Range { rFrom :: Roll, rTo :: Roll }
   deriving (Eq, Show)
 
-type TableMap = Map.Map Text.Text Table
+type TableMap = Map.Map TableName Table
 
 data Table = Table
   { tableName :: Text.Text
@@ -25,12 +28,43 @@ data Fragment
 data Result = Result { fromResult ::  [Fragment] }
     deriving (Eq, Show)
 
+-- * Values
+
 data Value = Value
-  { valueMsg :: Text.Text
+  { valueMsg     :: Text.Text
+  , valueFrom    :: TableName
+  , valueResult  :: Roll
+  , valueSources :: [Value]
   } deriving (Eq, Show)
 
+concatValues :: Context -> [Value] -> Value
+concatValues _ [v] = v
+concatValues Context { ctxSelf = table, ctxRoll = roll } vs = Value
+  { valueMsg     = foldMap valueMsg vs
+  , valueFrom    = table
+  , valueResult  = roll
+  , valueSources = vs
+  }
+
+bareValue :: Context -> Text.Text -> Value
+bareValue Context { ctxSelf = table, ctxRoll = roll } text = Value
+  { valueMsg     = text
+  , valueFrom    = table
+  , valueResult  = roll
+  , valueSources = []
+  }
+
 stripValue :: Value -> Value
-stripValue = Value . Text.strip . valueMsg
+stripValue value = value { valueMsg = Text.strip (valueMsg value) }
+
+-- * Exceptions
+
+data NoSuchTable = NoSuchTable Text.Text
+  deriving (Eq, Show)
+
+instance Exn.Exception NoSuchTable where
+
+-- * Context
 
 data Context = Context
   { ctxMap  :: TableMap
@@ -38,23 +72,25 @@ data Context = Context
   , ctxSelf :: Text.Text
   }
 
+-- * Evaluating Tables
+
 findTable :: Text.Text -> Context -> Maybe Table
 findTable name ctx = Map.lookup name (ctxMap ctx)
 
 computeFragments :: Context -> Fragment -> IO Value
-computeFragments _ (FragText msg) = pure (Value msg)
+computeFragments ctx (FragText msg) = pure (bareValue ctx msg)
 computeFragments ctx (FragRoll name) =
   let absolute = case Text.stripPrefix "self" name of
         Just rest -> ctxSelf ctx <> rest
         Nothing   -> name
   in case findTable absolute ctx of
     Just t -> rollTable (ctxMap ctx) t
-    Nothing -> error ("no such table: " ++ show absolute)
+    Nothing -> Exn.throwIO (NoSuchTable absolute)
 
 computeResult :: Context -> Result -> IO Value
 computeResult ctx (Result msgs) = do
   vs <- mapM (computeFragments ctx) msgs
-  pure (Value (foldMap valueMsg vs))
+  pure (concatValues ctx vs)
 
 tableDie :: Table -> Int
 tableDie t = maximum [ x | (Range _ x, _) <- tableChoices t ]