Pure, Lazy brainfuck interpreter in haskell

bf_adz.hs

import Data.Char
import Control.Monad.State.Lazy
import Control.Monad.Loops
import Text.ParserCombinators.Parsec hiding (State)
import System.Environment

data BF = NextPos | PrevPos | Inc |
          Dec | Out | In | While [BF]
        deriving(Show,Eq)


type BFProg = [BF]

data BFMachine = BFMachine { mem     :: ([Int], Int, [Int])
                           , display :: String
                           , code    :: BFProg
                           , stack   :: [BFProg]
                           , input   :: String
                           }
                 deriving (Show,Eq)


cellToChar = chr . fromIntegral


-- Parser from here http://sabbatical-year.blogspot.ru/2008/01/brainfuck-its-last-one-i-promise.html
program :: Parser [BF]
program = many instruction

instruction :: Parser (BF)
instruction = simple <|> loop

loop :: Parser (BF)
loop = between (char '[') (char ']') program >>= \p -> return $ While p

simple :: Parser (BF)
simple = ( (char '+') >> return  Inc)
     <|> ( (char '-') >> return  Dec)
     <|> ( (char '>') >> return  NextPos)
     <|> ( (char '<') >> return  PrevPos)
     <|> ( (char '.') >> return  Out)
     <|> ( (char ',') >> return  In)

memSet (l,p,r) x = (l,x,r)


memInc (l,p,r) = (l,(p+1),r)
memDec (l,p,r) | p <= 0     = (l,p-1,r)
               | otherwise = (l,p-1,r)

memShiftLeft  (l,!p,r) = (p:l     , head r, drop 1 r)
memShiftRight (l,!p,r) = (drop 1 l, head l, p:r)

memValue (l,p,r) = p



stepBF = do
  s@(BFMachine mem display c stack input) <- get
  let h = take 1 c
  let t = drop 1 c
  case h of
    [Inc] ->
      put (s {mem = memInc mem, code = t})
    [Dec] ->
      put (s {mem = memDec mem, code = t})
    [Out] ->
      put (s {display = (cellToChar (memValue mem) : display), code = t})
    [In] ->
      put (s {mem = memSet mem (ord (head input)), code = t, input = drop 1 input})
    [NextPos] ->
      put (BFMachine (memShiftLeft mem) display (t) stack input)
    [PrevPos] ->
      put (BFMachine (memShiftRight mem) display (t) stack input )

    -- save loop body and tail after loop on stack
    [While body] | memValue mem /= 0 -> do
      put (BFMachine mem display body (body:t:stack) input)

    -- no code in current block and mem=0 -> end of loop
    -- return to tail on stack and drop loop body and tail from stack
    [] | stack /= [] && memValue mem == 0 ->
      put (BFMachine mem display (stack !! 1) (drop 2 stack) input)

    -- no code in current block and mem /= 0 -> repeat loop
    -- return to loop body from stack
    [] | stack /= [] && memValue mem /= 0 ->
      put (BFMachine mem display (head stack) (stack) input)
    _ -> put (BFMachine mem display t stack input)

  if h == [Out]
    then return $ [cellToChar (memValue mem)]
    else return ""


showBF :: [BF] -> String
showBF a = showBF' 0 a
  where
    showBF' d [] = []
    showBF' d (x:xs) =
      case x of
        Inc -> '+': showBF' d xs
        In  -> ',': showBF' d xs
        Out -> '.': showBF' d xs
        Dec -> '-': showBF' d xs
        NextPos -> '>': showBF' d xs
        PrevPos -> '<': showBF' d xs
        While body -> ( "\n" ++ replicate d ' ' ++ ('[' : showBF' (d+1) body) ++
                        "\n" ++ replicate d ' ' ++  "]" ++ showBF' (d) xs)

debugBF (BFMachine (l,p,r) display c stack input) = do
  let nMem = 64
  putStrLn ""
  putStrLn "___________________________________"
  putStrLn $ "Code: " ++ showBF c
  putStrLn $ "Display: " ++ reverse display
  putStrLn "Stack:"
  mapM_ (putStrLn . (++"\n") . showBF) (stack)

  putStrLn $ "Code+Stack size: " ++ show( length (showBF c ++ concatMap showBF stack))
  putStrLn "Memory:"
  putStrLn $ ( unwords $ map show $ reverse $ take nMem l)
    ++ "\n {" ++ show p ++ "} \n"
    ++ (unwords $ map show $ take nMem r)
  putStrLn "___________________________________"

printDisplay (BFMachine (l,p,r) display c stack input) = do
  putStrLn $  reverse display


isBFChar '+' = True
isBFChar '-' = True
isBFChar '[' = True
isBFChar ']' = True
isBFChar '>' = True
isBFChar '<' = True
isBFChar ',' = True
isBFChar '.' = True
isBFChar _   = False


isEndProg  = do
  state <- get
  return $ (stack state == [])  && (code state == [])


runProg = runState (stepBF `untilM` isEndProg)

runProgSteps steps = runState (replicateM steps stepBF)



loadCode code input = (BFMachine (repeat 0, 0, repeat 0 )
                 [] code [] input)



interactive s0 | (stack s0 == [])  && (code s0 == []) = return ()
interactive s0 = do
  let (output, s1) = runState stepBF s0
  -- if next command is input then
  -- add char to input array
  putStr output
  if (take 1 ( code s1) == [In])
    then do c <- getChar
            interactive s1 {input = c:(input s1)}
    else interactive s1

parseBF src =
  case parse program "" (filter (isBFChar) src) of
    Right prog -> prog
    Left msg -> error $ show msg


main = do
  args <- getArgs
  case args of
    -- interactive mode
    [filename] -> do
      file <- readFile filename
      let prog = parseBF file
      let init = loadCode prog ""
      interactive init

    -- pure mode (fastest)
    [filename,input] -> do
      file <- readFile filename
      let prog = parseBF file
      let init = loadCode prog input
      let (output,machine) =  runProg init
      putStrLn $ concat $ output

    -- debug mode (goto to n step)
    ["-d", filename,steps,input] | all isDigit steps -> do
      file <- readFile filename
      let prog = parseBF file
      let init = loadCode prog input
      let nsteps = read steps
      let (output,machine) =  runProgSteps nsteps init
      debugBF machine
    _ -> do
      putStrLn "use:          ./bf prog.bf"
      putStrLn "     fastest  ./bf prog.bf input"
      putStrLn "     debug    ./bf -d prog.bf input n"