BrainFuck Arrow

Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections     #-}

module Main where

import           Control.Applicative
import           Control.Arrow
import           Control.Monad                    (void)
import           Data.Attoparsec.ByteString.Char8
import qualified Data.ByteString.Char8            as B
import           Data.List

type BFMemory = ([Int], [Int])
type BFArrow = Kleisli IO BFMemory BFMemory

parseBF :: B.ByteString -> Either String BFArrow
parseBF = parseOnly bfParser
  where
    bfParser = body <* endOfInput
    body = foldl' (>>>) (arr id) <$> many (atom <|> while)
    atom = incr <|> decr <|> next <|> prev <|> put <|> get
    incr = arr (\(x:xs, ys) -> (x+1:xs, ys)) <$ char '+'
    decr = arr (\(x:xs, ys) -> (x-1:xs, ys)) <$ char '-'
    next = arr (\(x:xs, ys) -> (xs, x:ys)) <$ char '>'
    prev = arr (\(xs, y:ys) -> (y:xs, ys)) <$ char '<'
    put = Kleisli (\m@(x:_, _) -> m <$ putChar (toEnum x)) <$ char '.'
    get = Kleisli (\(_:xs, ys) -> (, ys). (: xs) . fromEnum <$> getChar) <$ char ','
    while = buildWhile <$> "[" .*> body <*. "]"

buildWhile :: BFArrow -> BFArrow
buildWhile innerArrow = Kleisli doWhile
  where
    doWhile m@(0:_, _) = pure m
    doWhile m = runKleisli innerArrow m >>= doWhile

main::IO()
main = either parseError runBFArrow $ parseBF bfCode
  where
    parseError = putStr . ("Parse Error: " ++)
    runBFArrow = void . ($ (repeat 0, repeat 0)) . runKleisli
    bfCode = B.concat $
      [ "+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-."
      , "------------.<++++++++.--------.+++.------.--------.>+."
      ]

Memo.txt

ArrowLoop 使わずに、名前付けて再起しているの部分(doWhile)がカッコ悪い（＞＜）