brainf__k.hs

import qualified Data.Map as Map
import qualified Data.List as List

data AST = Cons AST AST | Inst Char | Nil deriving Show

-- Just for debugging purpose
toSEXP :: AST -> String
toSEXP x = case toSEXPList x of
  Just xs -> "(" ++ List.intercalate " " xs ++ ")"
  Nothing -> toSEXP' x

toSEXPList :: AST -> Maybe [String]
toSEXPList (Cons (Inst a) b) = do
  xs <- toSEXPList b
  Just $ [a] : xs
toSEXPList (Cons a@(Cons _ _) b) = do
  bs <- toSEXPList b
  Just $ [toSEXP a] ++ bs
toSEXPList Nil = Just []
toSEXPList _ = Nothing

toSEXP' :: AST -> String
toSEXP' (Cons a b) = "(" ++ toSEXP a ++ " . " ++ toSEXP b ++ ")"
toSEXP' Nil = "nil"
toSEXP' (Inst c) = [c]

parse :: String -> Either String AST
parse x = case parse' x of
            Left message -> Left message
            Right (ast, "") -> Right ast
            Right (_, remaining) -> Left remaining

parse' :: String -> Either String (AST, String)
parse' ('>' : remaining) = (\(a, r) -> (Cons (Inst '>') a, r)) `fmap` parse' remaining
parse' ('<' : remaining) = (\(a, r) -> (Cons (Inst '<') a, r)) `fmap` parse' remaining
parse' ('+' : remaining) = (\(a, r) -> (Cons (Inst '+') a, r)) `fmap` parse' remaining
parse' ('-' : remaining) = (\(a, r) -> (Cons (Inst '-') a, r)) `fmap` parse' remaining
parse' ('.' : remaining) = (\(a, r) -> (Cons (Inst '.') a, r)) `fmap` parse' remaining
parse' (',' : remaining) = (\(a, r) -> (Cons (Inst ',') a, r)) `fmap` parse' remaining
parse' ('[' : remaining) = do
  (a, r) <- parse' remaining
  (a', r') <- parse' r
  return (Cons a a', r')
parse' (']' : remaining) = return (Nil, remaining)
parse' "" = return (Nil, "")
parse' (_ : remaining) = parse' remaining

execute :: AST -> Int -> Map.Map Int Char -> IO (Int, Map.Map Int Char)
execute Nil i tape = return (i, tape)
execute (Cons (Inst '>') x) i tape = execute x (succ i) tape
execute (Cons (Inst '<') x) i tape = execute x (pred i) tape
execute (Cons (Inst '+') x) i tape = execute x i $ Map.alter (return . succ . maybe '\0' id) i tape
execute (Cons (Inst '-') x) i tape = execute x i $ Map.alter (return . pred . maybe '\0' id) i tape
execute (Cons (Inst '.') x) i tape = putChar (Map.findWithDefault '\0' i tape) >> execute x i tape
execute (Cons (Inst ',') x) i tape = print "Error: `,` NOT IMPLEMENTED" >> return (i, tape)
execute (Cons a b) i tape = do
  if (Map.findWithDefault '\0' i tape) == '\0'
    then execute b i tape
    else
      do
        (i', tape') <- execute a i tape
        execute (Cons a b) i' tape'

main = do
  case parse "++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]>>.>---.+++++++..+++.>>.<-.<.+++.------.--------.>>+.>++." of
    Left message -> print $ "ERROR: " ++ message
    Right ast -> do
      print ast
      putStrLn $ toSEXP ast
      execute ast 0 Map.empty
      return ()

z_output.txt

Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '<') (Cons (Inst '<') (Cons (Inst '<') (Cons (Inst '<') (Cons (Inst '-') Nil)))))))))))))))))) (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '>') (Cons (Inst '-') (Cons (Inst '>') (Cons (Inst '>') (Cons (Inst '+') (Cons (Cons (Inst '<') Nil) (Cons (Inst '<') (Cons (Inst '-') Nil)))))))))))))))))) (Cons (Inst '>') (Cons (Inst '>') (Cons (Inst '.') (Cons (Inst '>') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '.') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '.') (Cons (Inst '.') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '.') (Cons (Inst '>') (Cons (Inst '>') (Cons (Inst '.') (Cons (Inst '<') (Cons (Inst '-') (Cons (Inst '.') (Cons (Inst '<') (Cons (Inst '.') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '.') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '.') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '.') (Cons (Inst '>') (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '.') (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '.') Nil)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
(+ + + + + + + + (> + + + + (> + + > + + + > + + + > + < < < < -) > + > + > - > > + (<) < -) > > . > - - - . + + + + + + + . . + + + . > > . < - . < . + + + . - - - - - - . - - - - - - - - . > > + . > + + .)
Hello World!