BrainFuck compiler in Haskell

Main.hs

module Main where

import Text.Megaparsec hiding (Stream)
import Text.Megaparsec.Char
import Data.Text hiding (replicate)
import Data.Void
import Control.Monad.State
import System.Environment
import qualified Data.Text.IO as TIO

type Parser = Parsec Void Text

data BrainFuckCommands
  = ToRight
  | ToLeft
  | Read
  | Write
  | Succ
  | Pred
  | Cycle [BrainFuckCommands]
  deriving Show

data Stream a = a :> Stream a

data Tape a = Tape (Stream a) a (Stream a)

parseBrainFuck :: Parser [BrainFuckCommands]
parseBrainFuck = some $ space *> choice 
  [ ToLeft  <$   char '<' 
  , ToRight <$   char '>' 
  , Read    <$   char ',' 
  , Write   <$   char '.' 
  , Succ    <$   char '+' 
  , Pred    <$   char '-' 
  , Cycle   <$>  (char '[' *> parseBrainFuck <* char ']')
  ] <* space

tapeOf :: a -> Tape a
tapeOf x = Tape l x r
  where
    s@l@r = x :> s

moveL, moveR :: Tape a -> Tape a
moveL (Tape (x :> l) c r) = Tape l x (c :> r)
moveR (Tape l c (x :> r)) = Tape (c :> l) x r

getCurrent :: Tape a -> a
getCurrent (Tape _ c _) = c

setCurrent :: a -> Tape a -> Tape a
setCurrent c (Tape l _ r) = Tape l c r

modifyCurrent :: (a -> a) -> Tape a -> Tape a
modifyCurrent f  = setCurrent =<< (f . getCurrent) 


left, right :: MonadState (Tape a) m => m ()
left = modify moveL
right = modify moveR

getValue :: MonadState (Tape a) m => m a
getValue = gets getCurrent

putValue ::MonadState (Tape a) m => a -> m ()
putValue = modify . setCurrent

modifyValue :: MonadState (Tape a) m => (a -> a) ->  m ()
modifyValue f = modify $ modifyCurrent f


execCommand :: BrainFuckCommands -> StateT (Tape Char) IO ()
execCommand ToLeft               = left
execCommand ToRight              = right
execCommand Read                 = putValue =<< liftIO getChar
execCommand Write                = (liftIO . putChar =<< getValue)
execCommand Succ                 = modifyValue succ
execCommand Pred                 = modifyValue pred
execCommand cyc@(Cycle commands) = do
  execCommands commands
  ch <- getValue
  unless (ch == '\0') (execCommand cyc)

execCommands :: [BrainFuckCommands] -> StateT (Tape Char) IO ()
execCommands = mapM_ execCommand


main :: IO ()
main = do
  [fileName] <- getArgs
  code       <- TIO.readFile fileName
  case parse parseBrainFuck fileName code of
    Left err       -> putStrLn  $ errorBundlePretty err
    Right commands -> evalStateT (execCommands commands) (tapeOf '\0')