Another Brainfuck interpreter in Haskell

Question

I came up with the following Brainfuck interpreter in Haskell after thinking about how to represent the program and the memory functionally using zippers to represent current location. This works since in Brainfuck, there is no way to reference more than one memory location away from your present location at one time.

import Control.Monad
import System.Environment

data ZL a = EM | ZL [a] a [a]

fromList []           = EM
fromList (x:xs)       = ZL [] x xs
zprv EM               = EM
zprv (ZL [] x rs)     = EM
zprv (ZL (l:ls) x rs) = ZL ls l (x:rs)
znxt EM               = EM
znxt (ZL ls x [])     = EM
znxt (ZL ls x (r:rs)) = ZL (x:ls) r rs
zmap (ZL ls x rs) f   = ZL ls (f x) rs

run code = go (fromList (repeat 0)) (fromList code)
  where
    go m EM                          = return m
    go m              i@(ZL _ '>' _) = go (znxt m) (znxt i)
    go m              i@(ZL _ '<' _) = go (zprv m) (znxt i)
    go m              i@(ZL _ '+' _) = go (zmap m (\x -> x + 1)) (znxt i)
    go m              i@(ZL _ '-' _) = go (zmap m (\x -> x - 1)) (znxt i)
    go m@(ZL ml x mr) i@(ZL _ '[' _) = go m (if x /= 0 then znxt i else skip znxt 0 i)
    go m@(ZL ml x mr) i@(ZL _ ']' _) = go m (if x == 0 then znxt i else skip zprv 0 i)
    go m@(ZL  _ x  _) i@(ZL _ '.' _) = putChar (toEnum x) >> go m (znxt i)
    go m@(ZL ml _ mr) i@(ZL _ ',' _) = getChar >>= \x -> go (ZL ml (fromEnum x) mr) (znxt i)
    go m@(ZL ml x mr) i@(ZL _   _ _) = go m (znxt i) -- Ignore
    skip _  1 i@(ZL _ ']' _)         = znxt i
    skip _ (-1) i@(ZL _ '[' _)       = znxt i
    skip d  n i@(ZL l '[' r)         = skip d (n+1) (d i)
    skip d  n i@(ZL l ']' r)         = skip d (n-1) (d i)
    skip d  n i@(ZL l   _ r)         = skip d n (d i)

main = do
  getArgs >>= \args -> case args of
    []    -> putStrLn "Usage: bf <program.bf>"
    (x:_) -> readFile x >>= run >> return ()

Answer 1

I find this very difficult to read without any logical line breaks or function types given. I.e., you should leave a blank line between definitions for different functions, and every top-level definition should be given a type signature.

fromList :: [a] -> ZL a
fromList []     = EM
fromList (x:xs) = ZL [] x xs

zprv :: ZL a -> ZL a
zprv EM               = EM
zprv (ZL []     x rs) = EM
zprv (ZL (l:ls) x rs) = ZL ls l (x:rs)

-- &c...

zmap is a partial function, and it isn't acting much like a mapping as it only modifies the current element in your given definition. Maybe zapp is a better name? (Or poke, or prod, or...)

zapp :: (a -> a) -> ZL a -> ZL a
zapp _ EM           = EM             -- Or, raise a descriptive `error`
zapp f (ZL ls x rs) = ZL ls (f x) rs

The definition of run is extremely long and not very semantic, rewrite it to be the composition of smaller, more compositional, more meaningful functions.

zinc :: (Num a) => ZL a -> ZL a
zinc = zapp (+1)

zdec :: (Num a) => ZL a -> ZL a
zdec = zapp (subtract 1)

zjmp :: (ZL a -> ZL a) -> Int -> ZL a -> ZL a
zjmp _   1  i@(ZL _ ']' _) = znxt i
zjmp _ (-1) i@(ZL _ '[' _) = znxt i
zjmp d   n  i@(ZL l '[' r) = zjmp d (n+1) (d i)
zjmp d   n  i@(ZL l ']' r) = zjmp d (n-1) (d i)
zjmp d   n  i@(ZL l   _ r) = zjmp d n     (d i)

interpret :: ZL Int -> ZL Char -> IO ()
interpret _                 EM          = return ()
interpret m              i@(ZL _ '>' _) = interpret (znxt m) (znxt i)
interpret m              i@(ZL _ '<' _) = interpret (zprv m) (znxt i)
interpret m              i@(ZL _ '+' _) = interpret (zinc m) (znxt i)
interpret m              i@(ZL _ '-' _) = interpret (zdec m) (znxt i)
interpret m@(ZL _  x _ ) i@(ZL _ '[' _) = interpret m (if x /= 0 then znxt i else zjmp znxt 0 i)
interpret m@(ZL _  x _ ) i@(ZL _ ']' _) = interpret m (if x == 0 then znxt i else zjmp zprv 0 i)
interpret m@(ZL _  x _ ) i@(ZL _ '.' _) = putChar (toEnum x) >> interpret m (znxt i)
interpret m@(ZL ml _ mr) i@(ZL _ ',' _) = getChar >>= \x -> interpret (ZL ml (fromEnum x) mr) (znxt i)
interpret m              i@(ZL _ _   _) = interpret m (znxt i) -- Comment `Char`

run :: String -> IO ()
run program = interpret tape (fromList program)
    where
        tape :: ZL Int
        tape = fromList (repeat 0)

Your usage of do is redundant in main. You can either just drop the word do, or write it more idiomatically as—

main :: IO ()
main = do
          args <- getArgs
          case args of
              [x] -> do
                        program <- readFile x
                        run program
              _   -> usage
    where
        usage = putStrLn "Usage: bf FILE"

Answer 2

I am building on bisserlis' answer here. interpret uses a lot of repetition that can be reduced with case..of. That allows a where clause which factors out common code that modifies memory and simply advances the instruction pointer:

interpret m@(ZL _ x _) i@(ZL _ cmd _) =
    case cmd of
         '>'   -> memory znxt
         '<'   -> memory zprv
         '+'   -> memory zinc
         '-'   -> memory zdec
         '['   -> interpret m (if x /= 0 then znxt i else zjmp znxt 0 i)
         ']'   -> interpret m (if x == 0 then znxt i else zjmp zprv 0 i)
         '.'   -> putChar (toEnum x) >> memory id
         ','   -> getChar >>= memory . zapp . const . fromEnum
         _     -> memory id -- Comment `Char`
    where
        memory :: (ZL Int -> ZL Int) -> IO ()
        memory f = interpret (f m) (znxt i)

I would use longer names for znxt etc., then you might consider renaming zapp to underHead or atPtr and then your code might read like this (I am mixing styles here):

         '>'   -> memory advancePtr
         '<'   -> memory moveHeadLeft
         '+'   -> memory (underHead (+1))
         '-'   -> memory (atPtr (subtract 1))

Reads almost like the specification!