Improved error messages
Getty Ritter
9 years ago
| 5 | 5 | import Control.Monad (forever, void) |
| 6 | 6 | import Control.Monad.IO.Class (liftIO) |
| 7 | 7 | import Control.Monad.State (StateT (runStateT), get, modify, put) |
| 8 |
import Data.Array (Array, array, |
|
| 8 | import Data.Array (Array, array, bounds, (!), (//)) | |
| 9 | 9 | import Data.Char (chr, isDigit, ord) |
| 10 |
import Data.Maybe (fromMaybe |
|
| 10 | import Data.Maybe (fromMaybe, listToMaybe) | |
| 11 | 11 | import System.Environment (getArgs) |
| 12 |
import System.Exit (exit |
|
| 12 | import System.Exit (exitFailure, exitSuccess) | |
| 13 | 13 | import System.IO (hFlush, stdout) |
| 14 | 14 | import System.Random (randomIO) |
| 15 | 15 | |
| 24 | 24 | } deriving (Eq, Show) |
| 25 | 25 | type FungeM a = StateT FungeState IO a |
| 26 | 26 | |
| 27 | maybeRead :: Read a => String -> Maybe a | |
| 28 | maybeRead = fmap fst . listToMaybe . reads | |
| 29 | ||
| 30 | finish :: FungeM a | |
| 31 | finish = liftIO $ do { putStrLn ""; exitSuccess } | |
| 32 | ||
| 27 | 33 | terminate :: String -> FungeM a |
| 28 | terminate s = liftIO $ do | |
| 29 | putStrLn ("\n" ++ s) | |
| 30 | exitSuccess | |
| 34 | terminate s = do | |
| 35 | st <- get | |
| 36 | liftIO $ do | |
| 37 | let l = location st | |
| 38 | let i = board st ! l | |
| 39 | putStr ("\nbefunge: instr (" ++ [i] ++ ") at " ++ show l ++ "\n ") | |
| 40 | putStrLn s | |
| 41 | exitFailure | |
| 31 | 42 | |
| 32 | 43 | debug :: FungeM () |
| 33 | 44 | debug = do |
| 70 | 81 | x <- liftIO randomIO |
| 71 | 82 | setDirection (toEnum x) |
| 72 | 83 | |
| 84 | inBounds :: (Int, Int) -> Board -> Bool | |
| 85 | inBounds (x, y) board = x >= lx && y >= ly && x <= hx && y <= hy | |
| 86 | where ((lx, ly), (hx, hy)) = bounds board | |
| 87 | ||
| 73 | 88 | fungeIf :: Direction -> Direction -> FungeM () |
| 74 | 89 | fungeIf thenDir elseDir = do |
| 75 | 90 | c <- pop |
| 85 | 100 | goDir L (x, y) = (x - 1, y) |
| 86 | 101 | |
| 87 | 102 | move :: FungeM () |
| 88 | move = modify go | |
| 89 | where go st@(FS { direction = d, location = l }) = | |
| 90 | st { location = goDir d l } | |
| 103 | move = do | |
| 104 | st <- get | |
| 105 | let newLoc = goDir (direction st) (location st) | |
| 106 | if inBounds newLoc (board st) | |
| 107 | then put st { location = newLoc } | |
| 108 | else terminate ("About to move to invalid location: " ++ show newLoc) | |
| 91 | 109 | |
| 92 | 110 | getInstr :: FungeM () |
| 93 | 111 | getInstr = do |
| 94 | 112 | y <- pop |
| 95 | 113 | x <- pop |
| 96 | 114 | st <- get |
| 97 |
|
|
| 115 | if inBounds (x, y) (board st) | |
| 116 | then push (ord (board st ! (x, y))) | |
| 117 | else terminate ("Invalid board location: " ++ show (x, y)) | |
| 98 | 118 | |
| 99 | 119 | putInstr :: FungeM () |
| 100 | 120 | putInstr = do |
| 101 | 121 | y <- pop |
| 102 | 122 | x <- pop |
| 103 | 123 | c <- pop |
| 104 |
|
|
| 124 | st <- get | |
| 125 | if inBounds (x, y) (board st) | |
| 126 | then modify (\ st -> st { board = board st // [((x, y), chr c)] }) | |
| 127 | else terminate ("Invalid board location: " ++ show (x, y)) | |
| 105 | 128 | |
| 106 | 129 | step :: Char -> FungeM () |
| 107 | 130 | step '+' = binOp (+) |
| 130 | 153 | step '&' = do |
| 131 | 154 | liftIO (putStr "num> " >> hFlush stdout) |
| 132 | 155 | n <- liftIO getLine |
| 133 |
|
|
| 156 | case maybeRead n of | |
| 157 | Just n' -> push n' | |
| 158 | Nothing -> terminate ("Invalid number: " ++ show n) | |
| 134 | 159 | step '~' = do |
| 135 | 160 | liftIO (putStr "chr> " >> hFlush stdout) |
| 136 | 161 | n <- liftIO getLine |
| 137 | push (ord (head n)) | |
| 138 | step '@' = terminate "Finished" | |
| 162 | case n of | |
| 163 | [c] -> push (ord c) | |
| 164 | [] -> terminate "No character given" | |
| 165 | _ -> terminate ("Expected character, got string: " ++ show n) | |
| 166 | step '@' = finish | |
| 139 | 167 | step n | isDigit n = push (ord n - ord '0') |
| 140 | 168 | step _ = return () |
| 141 | 169 | |
| 179 | 207 | runFunge :: FungeState -> IO () |
| 180 | 208 | runFunge st = void (runStateT (forever run) st) |
| 181 | 209 | |
| 210 | usage :: String | |
| 211 | usage = "USAGE: befunge [filename]" | |
| 212 | ||
| 182 | 213 | main :: IO () |
| 183 | 214 | main = do |
| 184 | 215 | args <- getArgs |
| 185 | 216 | case args of |
| 186 |
[] -> putStrLn |
|
| 217 | [] -> putStrLn usage | |
| 187 | 218 | (f:_) -> do |
| 188 | 219 | c <- readFile f |
| 189 | 220 | runFunge (buildInitialState c) |