Since implementing my Interactive Brainfuck interpreter in Haskell I figured that it would be a good idea to build upon an Abstract Syntax Tree. I have also decided to drop replacing the IO
monad by some other structure for the time being as what I have now works fine, and fast.
The code consists of the following:
- The main application
- The tape
- The application
Main.hs
module Main where
import Control.Monad
import qualified Data.Map as Map
import System.Environment
import Interpreter
data SimpleOption = ShowProgram | ShowMemory deriving (Enum, Eq, Ord, Show)
data AdvancedOption = Program | File deriving (Enum, Eq, Ord, Show)
data Options = Options [SimpleOption] (Map.Map AdvancedOption String) deriving (Show)
addSimpleOption :: SimpleOption -> Options -> Options
addSimpleOption opt (Options sOpts aOpts) = Options (opt:sOpts) aOpts
addAdvancedOption :: AdvancedOption -> String -> Options -> Options
addAdvancedOption opt val (Options sOpts aOpts) = Options sOpts (Map.insert opt val aOpts)
isOptionsEmpty :: Options -> Bool
isOptionsEmpty (Options sOpts aOpts) = null sOpts && Map.null aOpts
main :: IO ()
main = do
args <- getArgs
case parseArgs args (Options [] Map.empty) >>= validateOptions of
Left err -> putStrLn err
Right opts -> execute opts
execute :: Options -> IO ()
execute opts@(Options sOpts _) = do
program <- getProgram opts
(program', memory) <- interpret program
when (ShowProgram `elem` sOpts) $ putStrLn ("\n" ++ show program')
when (ShowMemory `elem` sOpts) $ putStrLn ("\n" ++ show memory)
getProgram :: Options -> IO String
getProgram (Options _ aOpts) = case Map.lookup Program aOpts of
Nothing -> case Map.lookup File aOpts of
Just file -> readFile file
Just program -> return program
parseArgs :: [String] -> Options -> Either String Options
parseArgs [] opts = if isOptionsEmpty opts then Left usage else Right opts
parseArgs [program] opts = Right $ addAdvancedOption Program program opts
parseArgs ("-sp":args) opts = parseArgs args (addSimpleOption ShowProgram opts)
parseArgs ("-sm":args) opts = parseArgs args (addSimpleOption ShowMemory opts)
parseArgs ("-p":program:args) opts = parseArgs args (addAdvancedOption Program program opts)
parseArgs ("-f":file:args) opts = parseArgs args (addAdvancedOption File file opts)
parseArgs _ _ = Left usage
usage :: String
usage = "Usage: bf-interpreter-ast-exe [-sp] [-sm] [-f file] [-p program | program]"
validateOptions :: Options -> Either String Options
validateOptions opts@(Options _ aOpts)
| Program `Map.member` aOpts && File `Map.member` aOpts = Left "Error: Only one of the options File and Program can be present"
| Program `Map.member` aOpts || File `Map.member` aOpts = Right opts
| otherwise = Left "Error: One of the options File and Program must be present"
Tape.hs
module Tape
( Tape(..)
, makeTape
, forwardTape
, reverseTape
, tapeValue
, onTapeValue
) where
data Tape a = Tape [a] !a [a] deriving (Eq)
instance Show a => Show (Tape a) where
show (Tape ls v rs) = show (reverse ls) ++ " " ++ show v ++ " " ++ show rs
makeTape :: a -> Tape a
makeTape def = Tape [] def []
forwardTape :: a -> Tape a -> Tape a
forwardTape def (Tape ls v []) = Tape (v:ls) def []
forwardTape _ (Tape ls v rs) = Tape (v:ls) (head rs) (tail rs)
reverseTape :: a -> Tape a -> Tape a
reverseTape def (Tape [] v rs) = Tape [] def (v:rs)
reverseTape _ (Tape ls v rs) = Tape (tail ls) (head ls) (v:rs)
tapeValue :: Tape a -> a
tapeValue (Tape _ v _) = v
onTapeValue :: (a -> a) -> Tape a -> Tape a
onTapeValue func (Tape ls v rs) = Tape ls (func v) rs
Interpreter.hs
module Interpreter
( interpret
) where
import Data.Word
import System.IO
import Tape
data BFInstruction = MemoryRight | MemoryLeft | Increment | Decrement | Output | Input | Loop [BFInstruction] deriving (Eq, Show)
type BFProgram = [BFInstruction]
newtype BFMemoryCell = BFMemoryCell Word8 deriving (Eq, Show)
type BFMemory = Tape BFMemoryCell
cellValue :: BFMemoryCell -> Word8
cellValue (BFMemoryCell val) = val
onCellValue :: (Word8 -> Word8) -> BFMemoryCell -> BFMemoryCell
onCellValue func (BFMemoryCell val) = BFMemoryCell $ func val
makeProgram :: String -> BFProgram
makeProgram = makeProgram'
makeProgram' :: String -> BFProgram
makeProgram' "" = []
makeProgram' (x:xs) = case x of
'>' -> continue MemoryRight
'<' -> continue MemoryLeft
'+' -> continue Increment
'-' -> continue Decrement
'.' -> continue Output
',' -> continue Input
'[' -> do
let (loop, rest) = splitOnLoopEnd xs
Loop (makeProgram loop):makeProgram' rest
']' -> []
_ -> makeProgram' xs
where
continue instr = instr:makeProgram' xs
splitOnLoopEnd :: String -> (String, String)
splitOnLoopEnd = splitOnLoopEnd' 0
splitOnLoopEnd' :: Int -> String -> (String, String)
splitOnLoopEnd' _ "" = error "No matching ] found"
splitOnLoopEnd' 0 (']':xs') = ([], xs')
splitOnLoopEnd' nesting (x:xs') = case x of
']' -> (x:ys, zs) where (ys, zs) = next (subtract 1)
'[' -> (x:ys, zs) where (ys, zs) = next (+1)
_ -> (x:ys, zs) where (ys, zs) = next id
where
next func = splitOnLoopEnd' (func nesting) xs'
interpret :: String -> IO (BFProgram, BFMemory)
interpret input = do
let program = makeProgram input
let memory = makeTape (BFMemoryCell 0)
memory' <- execute program memory
return (program, memory')
execute :: BFProgram -> BFMemory -> IO BFMemory
execute [] memory = return memory
execute xs@(x:xs') memory = case x of
MemoryRight -> continue $ forwardTape (BFMemoryCell 0) memory
MemoryLeft -> continue $ reverseTape (BFMemoryCell 0) memory
Increment -> continue $ onTapeValue (onCellValue (+1)) memory
Decrement -> continue $ onTapeValue (onCellValue (subtract 1)) memory
Output -> do
putChar $ toEnum . fromEnum . cellValue . tapeValue $ memory
hFlush stdout
continue memory
Input -> do
ch <- getChar
continue $ onTapeValue (\_ -> BFMemoryCell . toEnum . fromEnum $ ch) memory
Loop program' -> if cellValue (tapeValue memory) == 0
then continue memory
else do
memory' <- execute program' memory
execute xs memory'
where
continue = execute xs'