DouKaku?

import Data.List
import System.Environment

putCode '>' = putStr "incP >=> "
putCode '<' = putStr "decP >=> "
putCode '+' = putStr "inc >=> " 
putCode '-' = putStr "dec >=> " 
putCode '.' = putStr "put >=> " 
putCode ',' = putStr "get >=> " 
putCode '[' = putStr "loop("
putCode ']' = putStr "return) >=> "

genCode source 
    = do putStr "runBF = "
         mapM_ putCode (source `intersect` "><+-.,[]")
         putStrLn "return"

main = do
    source <- readFile . head =<< getArgs

    putStrLn "import Data.Char"
    putStrLn "(>=>) m1 m2 = \\s -> m1 s >>= m2"
    putStrLn "incP (ps, n:ns)    = return (n:ps, ns)"
    putStrLn "decP (p:ps, ns)    = return (ps, p:ns)"
    putStrLn "inc (ps, n:ns)     = return (ps, n+1:ns)"
    putStrLn "dec (ps, n:ns)     = return (ps, n-1:ns)"
    putStrLn "put mem@(_, n:_)   = putChar (chr n) >> return mem"
    putStrLn "get mem@(ps, _:ns) = getChar >> (\\c -> return (ps, ord c:ns))"
    putStrLn "loop code mem@(_, 0:_) = return mem"
    putStrLn "loop code mem = code mem >>= loop code"
    genCode source
    putStrLn "main = runBF ([0,0..], [0,0..])"

-- bfc.hs : BF コンパイラ ---------------------------------------------------
module Main where

import Data.Char
import Data.List
import System.IO
import System.Environment

main = do { args <- getArgs
          ; case args of
              []  -> runcompiler stdin stdout
              s:_ -> do { ih <- openFile (s++".b") ReadMode
                        ; oh <- openFile (s++".hs") WriteMode
                        ; runcompiler ih oh
                        }
          }

runcompiler ih oh =
 do { cs <- hGetContents ih
    ; let cs' = zip [0..] $ filter (not . isSpace) cs
    ; outputCode oh $ compile cs'
    }

compile [] = []
compile (c:cs) = case c of
  (_,'>') -> "incp" : compile cs
  (_,'<') -> "decp" : compile cs
  (_,'+') -> "incc" : compile cs
  (_,'-') -> "decc" : compile cs
  (_,'.') -> "putc" : compile cs
  (_,',') -> "getc" : compile cs
  (_,']') -> "jmpb" : compile cs
  (_,'[') -> ("jmpf "++show pc) : compile cs
               where pc = findpc [] cs
  _       -> error "invalid input"

findpc s []     = error "syntax error"
findpc s (c:cs) = case c of
  (_,'[') -> findpc ('[':s) cs
  (p,']') -> case s of
               [] -> p+1
               _  -> findpc (tail s) cs
  _       -> findpc s cs

outputCode h s 
 = do { hd <- readFile "bfrts.tmpl"
      ; hPutStrLn h hd
      ; hPutStrLn h "codeL :: [Instruction]"
      ; hPutStr h "codeL = ["
      ; hPutStr h (concat (intersperse "," s))
      ; hPutStr h "]\n"
      }

-- bfrts.templ : ランタイムテンプレート -------------------------------------

module Main where

import Control.Monad.State
import Data.Array as A
import Data.Char
import Data.IntMap as M
import Debug.Trace

type PC      = Int
type Code    = Array PC Instruction
type Heap    = M.IntMap Char
type Stack   = [PC]
type Pointer = Int
type VM   = (Stack,PC,Heap,Pointer)

type Instruction = VM -> StateT VM IO ()

top = head
pop = tail
push = (:)

-- initial machine state

iStat = ([],0,M.fromList $ zip [0..29999] (repeat $ chr 0),0)

-- instruction set

incp,decp,incc,decc,putc,getc,jmpb :: Instruction
jmpf :: PC -> Instruction
incp (s,c,h,p) = put (s,succ c,h,succ p)
decp (s,c,h,p) = put (s,succ c,h,pred p)
incc (s,c,h,p) = put (s,succ c,M.update (Just . succ) p h,p)
decc (s,c,h,p) = put (s,succ c,M.update (Just . pred) p h,p)
putc (s,c,h,p) = liftIO (putChar (h M.! p)) >> put (s,succ c,h,p)
getc (s,c,h,p) = liftIO (getChar >>= \ ch -> return (s,succ c,M.update (const (Just ch)) p h,p)) >>= put
jmpb (s,c,h,p) = if h M.! p == chr 0 then put (pop s,succ c,h,p) else put (s,top s,h,p)
jmpf pc (s,c,h,p) = if h M.! p == chr 0 then put (s,pc,h,p) else put (push (succ c) s,succ c,h,p)

-- run compiled bf code
             
main :: IO ()
main = evalStateT execute iStat >> putStrLn ""

run = do { stat@(s,c,h,p) <- get
         ; if inRange (bounds code) c then (code A.! c) stat >> run
           else return () 
         }

code :: Code 
code = listArray (0,length codeL - 1) codeL

-- この下にコンパイル済みの codeL :: [Instruction] が追加される

-- import Maybe
-- import Control.Monad

-- -- where pc = findpc [] cs
-- where pc = findpc cs

findpc cs = fromMaybe (error "syntax error")
  $ msum $ snd $ mapAccumL f 0 cs  where
    f 0 (p,']') = (0, Just (p+1))
    f s (_,c) = (s+d, Nothing) where
      d = case c of; ']' -> (-1); '[' -> 1; _ -> 0