A stupid simple BF interpreter

BF.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}

module Main where

import Data.Char
import Text.Parsec
import Text.Parsec.String

data Machine = Machine ![Int] !Int ![Int] deriving Show

data Op
  = Inc
  | Dec
  | Inp
  | Out
  | Lft
  | Rgt
  | Loop ![Op]
  deriving Show

helloworld :: String
helloworld =
  "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++\
  \.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.\
  \------.--------.>+.>."

main :: IO ()
main =
  case parse bfP "BF" helloworld of
    Left e -> print e
    Right pgm -> () <$ runBF initial pgm

bfP :: Parser [Op]
bfP = many (loopP <|> opP) <* eof

opP :: Parser Op
opP = anyChar >>= \case
  '+' -> pure Inc
  '-' -> pure Dec
  ',' -> pure Inp
  '.' -> pure Out
  '<' -> pure Lft
  '>' -> pure Rgt
  c   -> fail $ "Bad char: " <> [c]

loopP :: Parser Op
loopP =
  between (char '[') (char ']')
  $ Loop <$> many (try opP <|> loopP)

initial :: Machine
initial = Machine [] 0 []

runBF :: Machine -> [Op] -> IO Machine
runBF !m = \case
  []     -> pure m
  (x:xs) ->
    (`runBF` xs) =<< case x of
      Inc -> pure $ inc m
      Dec -> pure $ dec m
      Inp -> (`put` m) . ord <$> getChar
      Out -> m <$ putChar (chr $ get m)
      Lft -> pure $ lft m
      Rgt -> pure $ rgt m
      Loop p -> loop m p

inc, dec :: Machine -> Machine
inc (Machine l x r) = Machine l (x + 1) r
dec (Machine l x r) = Machine l (x - 1) r

lft, rgt :: Machine -> Machine
lft (Machine []     x rs) = Machine [] 0 (x:rs)
lft (Machine (l:ls) x rs) = Machine ls l (x:rs)
rgt (Machine ls x     []) = Machine (x:ls) 0 []
rgt (Machine ls x (r:rs)) = Machine (x:ls) r rs

put :: Int -> Machine -> Machine
put x (Machine l _ r) = Machine l x r

get :: Machine -> Int
get (Machine _ x _) = x

loop :: Machine -> [Op] -> IO Machine
loop !m p
  | get m == 0 = pure m
  | otherwise  = runBF m p >>= (`loop` p)