Brainfuck in Haskell, again

As often happens when I decide to revise Haksell, I've written a Brainfuck interpreter. This time around, there is better error handling, an optimisation stage, and a main procedure.

import IO
import System.Environment

-- Parser
type Cell = Int
type LineNum = Int
data Token = Leftward | Rightward | Plus Cell | In | Out | Loop [Token]
type Parsed = ([Token], String, LineNum)

parseChars :: String -> LineNum -> Parsed
parseChars [] l = ([], [], l)
parseChars (c:s) l = parseChar c s l
parseChar :: Char -> String -> LineNum -> Parsed
parseChar '<' = parseChar' Leftward
parseChar '>' = parseChar' Rightward
parseChar '+' = parseChar' (Plus 1)
parseChar '-' = parseChar' (Plus (-1))
parseChar ',' = parseChar' In
parseChar '.' = parseChar' Out
parseChar '[' =
  \s l -> let (ts, s', l') = parseChars s l in
    if null s' then
      error("Unmatched [ on line " ++ show l)
    else
      parseChar' (Loop ts) (tail s') l'
parseChar ']' = \s l -> ([], ']':s, l)
parseChar '\n' = \s l -> parseChars s (l + 1)
parseChar _ = parseChars
parseChar' :: Token -> String -> LineNum -> Parsed
parseChar' t s l = (t:ts, s', l') where (ts, s', l') = parseChars s l
parse :: String -> [Token]
parse s =
  if null s' then
    ts
  else
    error ("Unmatched ] on line " ++ show l)
  where (ts, s', l) = parseChars s 1

-- Optimiser
optimise :: [Token] -> [Token]
optimise ((Plus n):(Plus m):ts) = optimise ((Plus (n+m)):ts)
optimise ((Loop t):(Loop _):ts) = optimise ((Loop t):ts)
optimise (Leftward:Rightward:ts) = optimise ts
optimise (Rightward:Leftward:ts) = optimise ts
optimise ((Plus 0):ts) = optimise ts
optimise ((Loop t):ts) = (Loop (optimise t)):(optimise ts)
optimise (t:ts) = t:(optimise ts)
optimise [] = []

-- Evaluator
type Tape = ([Cell], Cell, [Cell])

eval1 :: Token -> Tape -> IO Tape
eval1 In s@(ls, _, rs) =
  getChar >>= \c ->
    if c == '\r' then
      eval1 In s
    else
      return (ls, fromEnum c, rs)
eval1 Out s@(_, c, _) = (putChar (toEnum c) >> return s)
eval1 t@(Loop ts) s@(_, c, _) =
  if c == 0 then
    return s
  else
    (eval' s ts) >>= (eval1 t)
eval1 Leftward (l:ls, c, rs) = return (ls, l, c:rs)
eval1 Rightward (ls, c, r:rs) = return (c:ls, r, rs)
eval1 (Plus n) (ls, c, rs) = return (ls, (c + n) `mod` 256, rs)
eval' :: Tape -> [Token] -> IO Tape
eval' e = foldl (\s t -> s >>= eval1 t) (return e)
eval :: [Token] -> IO ()
eval ts = eval' (repeat 0, 0, repeat 0) ts >> return ()

-- Glue
main :: IO ()
main = getArgs
   >>= (\ss -> if null ss then getContents else readFile (head ss))
   >>= eval . optimise . parse