Moderately optimizing brainfuck-to-C compiler.

bf2c.hs

{-# LANGUAGE LambdaCase #-}

import qualified Data.Attoparsec.Text as P
import qualified Data.Text as T
import qualified Data.Text.IO as TIO

import Control.Applicative
import Data.Char
import Data.List
import Data.Word 
import Text.Printf

import System.Environment
import System.FilePath
import System.Directory

{- TODO : cmd line opt parsing -}

data Ins = Add Int 
         | AddTimes Int 
         | Mov Int 
         | Getch 
         | Putch 
         | While [Ins]
         | SetTmp
         | Assign Int 
         deriving Show

parser :: P.Parser [Ins]
parser = P.many' $
        Add 1    <$  P.char '+'
    <|> Add (-1) <$  P.char '-'
    <|> Mov 1    <$  P.char '>'
    <|> Mov (-1) <$  P.char '<'
    <|> While    <$> (P.char '[' *> parser <* P.char ']')
    <|> Getch    <$  P.char ','
    <|> Putch    <$  P.char '.'

parse :: T.Text -> [Ins]
parse = either (error "Parse error") id 
      . P.parseOnly (parser <* P.endOfInput)
      . T.filter (`elem` "+-<>,.[]")

loopElim :: [Ins] -> [Ins]
loopElim (While [] : xs)  = loopElim xs
loopElim (While block:xs) = let

    insCheck = all (\case Add _ -> True; Mov _ -> True; _ -> False) block
    movCheck = sum [n | Mov n <- block] == 0

    decCheck = snd (foldr go (0, 0) block) == -1 where
        go (Mov n) (i, s) = (i + n, s)
        go (Add n) (0, s) = (0, s + n)
        go _ x = x

    in if insCheck && movCheck && decCheck
        then SetTmp : map (\case Add n -> AddTimes n; x -> x) block ++ loopElim xs
        else While block : loopElim xs

loopElim (x:xs) = x: loopElim xs
loopElim []     = []

movMerge :: [Ins] -> [Ins]
movMerge = go where
    go (While block:xs) = While (go block) : go xs
    go (Mov a:Mov b:xs) = go (Mov (a + b):xs)
    go (Mov 0: xs)      = go xs
    go (x:xs)           = x: go xs
    go []               = []

addMerge :: [Ins] -> [Ins]
addMerge = go where
    go (While block:xs) = While (go block) : go xs
    go (Add a:Add b:xs) = go (Add (a + b):xs)
    go (Add 0: xs)      = go xs
    go (x:xs)           = x: go xs
    go []               = []

assignMerge :: [Ins] -> [Ins]
assignMerge = go where
    go (While block:xs)    = While (go block) : go xs
    go (Assign 0:Add n:xs) = Assign n:go xs
    go (x:xs)              = x: go xs
    go []                  = []

tmpZeroAssign :: [Ins] -> [Ins]
tmpZeroAssign = go where
    go (While block:xs)          = While (go block) : go xs
    go (SetTmp:AddTimes (-1):xs) = SetTmp:Assign 0: go xs
    go (x:xs)                    = x : go xs
    go []                        = []

zeroAssign :: [Ins] -> [Ins]
zeroAssign = map $ \case 
    While [Add (-1)] -> Assign 0
    While block      -> While (zeroAssign block)
    x                -> x

optimize :: [Ins] -> [Ins]
optimize = assignMerge . tmpZeroAssign . movMerge 
         . loopElim . addMerge . zeroAssign

toC :: [Ins] -> String
toC xs = let
    header = concat [
        "#include <stdio.h>\n\n",
        "int main(){\n",
        "    char data[30000] = {};\n",
        "    char* p = data;\n",
        "    char tmp;\n"]

    tab = ("    " ++)

    fmt tab' (While block) = 
        tab' "while (*p) {\n" : (fmt (tab . tab') =<< block) ++ [tab' "}\n"]

    fmt tab x = (:[]) $ tab $ case x of
        Assign n      -> printf "*p = %d;\n" n
        SetTmp        -> "tmp = *p;\n"
        AddTimes 1    -> "*p += tmp;\n" 
        AddTimes (-1) -> "*p -= tmp;\n"
        AddTimes n    -> printf "*p += tmp * %d;\n" n
        Add n         -> printf "*p += %d;\n" n
        Mov n         -> printf "p += %d;\n" n
        Getch         -> "*p = getchar();\n"
        Putch         -> "putchar(*p);\n"

    in header ++ (concat $ (fmt tab) =<< xs) ++ "}\n"

helloWord = T.pack $ 
    "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++." 
    ++ ">++.<<+++++++++++++++.>.+++.------.--------.>+.>."


main = putStrLn $ toC $ optimize $ parse helloWord