Brainf**k interpreter in Haskell.

brainf.hs

{-
Brainf**k interpreter

Brainf**k is a Turing-complete programming language.

Instructions:
>   Increment data pointer so that it points to next location in memory.
<   Decrement data pointer so that it points to previous location in memory.
+   Increment the byte pointed by data pointer by 1. If it is already at its maximum value, 255, then new value will be 0.
-   Decrement the byte pointed by data pointer by 1. If it is at its minimum value, 0, then new value will be 255.
.   Output the character represented by the byte at the data pointer.
,   Read one byte and store it at the memory location pointed by data pointer.
[   If the byte pointed by data pointer is zero, then move instruction pointer to next matching ']', otherwise move instruction pointer to next command.
]   If the byte pointed by data pointer is non-zero, then move instruction pointer to previous matching '[' command, otherwise to next command.

Example. The first line of hello-world.bf must contain the input ('$' means there is no input).

hello-world.bf:
$
+++++ +++++             initialize counter (cell #0) to 10
[                       use loop to set the next four cells to 70/100/30/10
    > +++++ ++              add  7 to cell #1
    > +++++ +++++           add 10 to cell #2
    > +++                   add  3 to cell #3
    > +                     add  1 to cell #4
    <<<< -                  decrement counter (cell #0)
]
> ++ .                  print 'H'
> + .                   print 'e'
+++++ ++ .              print 'l'
.                       print 'l'
+++ .                   print 'o'
> ++ .                  print ' '
<< +++++ +++++ +++++ .  print 'W'
> .                     print 'o'
+++ .                   print 'r'
----- - .               print 'l'
----- --- .             print 'd'
> + .                   print '!'

$ ghc -O2 brainf.hs
$ ./brainf < hello-world.bf
Hello World!
-}

{-# LANGUAGE BangPatterns #-}

import           Data.Word ( Word8 )
import           Data.Char ( chr )
import           Control.Applicative
import           Control.Arrow
import           Text.Printf

type Program = [BFInstruction]

data BFInstruction = BFNext | BFPrev   -- memory movements
                   | BFInc  | BFDec    -- increment / decrement
                   | BFPut  | BFGet    -- to stdout / from stdin
                   | BFLoop Program    -- loops
                   deriving Show

newtype Input = Input String
newtype Output = Output String

parse [] = Right []
parse (x:xs) =
  case x of
    '>' -> BFNext <$:> parse xs
    '<' -> BFPrev <$:> parse xs
    '+' -> BFInc <$:> parse xs
    '-' -> BFDec <$:> parse xs
    '.' -> BFPut <$:> parse xs
    ',' -> BFGet <$:> parse xs
    '[' -> case _lp xs 0 of
             Left s -> Left s
             Right (lp, xs') -> BFLoop `fmap` parse lp <:> parse xs'
    -- ']' is already handled by _lp
    ']' -> Left "Unexpected ']'"
    _   -> parse xs

_lp :: String -> Int -> Either String (String, String)
_lp [] _ = Left "Unclosed '['"
_lp (']':xs) 0 = Right ([], xs)
_lp (']':xs) lvl = ']' <$:-> _lp xs (lvl + 1)
_lp ('[':xs) lvl = '[' <$:-> _lp xs (lvl - 1)
_lp (x:xs) lvl = x <$:-> _lp xs lvl

x <$:> xs = fmap (x:) xs
x <$:-> xs = fmap (first (x:)) xs
(<:>) = liftA2 (:)

data Tape a = Tape { memL :: [a], cell :: a, memR :: [a] }

forward  :: Tape a -> Tape a
forward Tape { memL = memL, cell = cell, memR = (mr:mrs) } = Tape { memL = cell : memL, cell = mr, memR = mrs }

backward :: Tape a -> Tape a
backward Tape { memL = (ml:mls), cell = cell, memR = memR } = Tape { memL = mls, cell = ml, memR = cell : memR }

modify :: (a -> a) -> Tape a -> Tape a
modify f t@Tape { cell = cell} = t { cell = f cell }

value :: Tape Word8 -> Word8
value Tape { cell = cell } = cell

pu :: Tape Word8 -> (BFInstruction, Input) -> (Tape Word8, Input, Output)
pu t (i, input@(Input inp)) =
    case i of
      BFInc    -> taped $ modify (+1) t
      BFDec    -> taped $ modify (subtract 1) t
      BFPrev   -> taped $ backward t
      BFNext   -> taped $ forward t
      BFGet    -> let t' = modify (const . toWord8 . head $ inp) t
                  in (t', Input $ tail inp, Output "")
      BFPut    -> (t, input, Output (toString $ value t))
      BFLoop p  -> bfloop p t input
  where
    taped t' = (t', input, Output "") -- No output, no input consumption
    bfloop p' t' input' | value t' == 0 = taped t'
                        | otherwise = let (t1, input1, Output out1) = interpret p' t' input'
                                          (t2, input2, Output out2) = bfloop p' t1 input1
                                      in (t2, input2, Output (out1 ++ out2))

-- TODO: count the number of operations
-- interpr :: Program -> Tape -> Int -> Input -> (Tape, Input, Output)

interpret :: Program -> Tape Word8 -> Input -> (Tape Word8, Input, Output)
interpret [] t input = (t, input, Output "")
interpret (i:ins) t input = (t2, input2, Output (out ++ out2))
  where (t1, input1, Output out) = pu t (i, input)
        (t2, input2, Output out2) = interpret ins t1 input1

toWord8 :: Char -> Word8
toWord8 = fromIntegral . fromEnum

toString :: Word8 -> String
toString = (:[]) . chr . fromIntegral

initial :: Tape Word8
initial = Tape { memL = repeat 0, cell = 0, memR = repeat 0 }

main = do
  input <- Input <$> getLine
  code <- getContents

  let result = case parse code of
                 Left error -> "Parsing error: " ++ error
                 Right program ->
                   let (t', _, Output out) = interpret program initial input
                   in out

  putStr result