Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
148 lines (113 sloc) 4.05 KB
{-# LANGUAGE TypeOperators #-}
-----------------------------------------------------------------------------
-- |
-- Module : Brainfuck
-- Copyright : (C) 2012 Edward Kmett, nand`
-- License : BSD-style (see the file LICENSE)
-- Maintainer : Edward Kmett <ekmett@gmail.com>
-- Stability : provisional
-- Portability : TH, Rank2, NoMonomorphismRestriction
--
-- A simple interpreter for the esoteric programming language "Brainfuck"
-- written using lenses and zippers.
-----------------------------------------------------------------------------
module Main where
import Prelude hiding (Either(..))
import Control.Lens
import Control.Applicative
import Control.Monad.Free
import Control.Monad.RWS
import qualified Data.ByteString.Lazy as BS
import Data.Maybe (fromMaybe)
import qualified Data.Stream.Infinite as S
import Data.Word (Word8)
import System.Environment (getArgs)
import System.IO
-- Low level syntax form
data Instr = Plus | Minus | Right | Left | Comma | Dot | Open | Close
type Code = [Instr]
parse :: String -> Code
parse = concatMap (maybe [] return . (`lookup` symbols))
where symbols = [ ('+', Plus ), ('-', Minus), ('<', Left), ('>', Right)
, (',', Comma), ('.', Dot ), ('[', Open), (']', Close) ]
-- Higher level semantic graph
data Brainfuck n
= Succ n | Pred n -- Increment or decrement the current value
| Next n | Prev n -- Shift memory left or right
| Read n | Write n -- Input or output the current value
-- Branching semantic, used for both sides of loops
| Branch { zero :: n, nonzero :: n }
type Program = Free Brainfuck ()
compile :: Code -> Program
compile = fst . bracket []
bracket :: [Program] -> Code -> (Program, [Program])
bracket [] [] = (Pure (), [])
bracket _ [] = error "Mismatched opening bracket"
bracket [] (Close:_) = error "Mismatched closing bracket"
-- Match a closing bracket: Pop a forward continuation, push backwards
bracket (c:cs) (Close : xs) = (Free (Branch n c), n:bs)
where (n, bs) = bracket cs xs
-- Match an opening bracket: Pop a backwards continuation, push forwards
bracket cs (Open : xs) = (Free (Branch b n), bs)
where (n, b:bs) = bracket (n:cs) xs
-- Match any other symbol in the trivial way
bracket cs (x:xs) = over _1 (Free . f x) (bracket cs xs)
where
f Plus = Succ; f Minus = Pred
f Right = Next; f Left = Prev
f Comma = Read; f Dot = Write
-- * RWS-based interpreter
type Cell = Word8
type Input = S.Stream Cell
type Output = [Cell]
type Memory = Top :> [Cell] :> Cell -- list zipper
type Interpreter = RWS Input Output Memory ()
-- | Initial memory configuration
initial :: Memory
initial = zipper (replicate 30000 0) & fromWithin traverse
interpret :: Input -> Program -> Output
interpret i p = snd $ execRWS (run p) i initial
-- | Evaluation function
run :: Program -> Interpreter
run (Pure _) = return ()
run (Free f) = case f of
Succ n -> focus += 1 >> run n
Pred n -> focus -= 1 >> run n
Next n -> modify wrapRight >> run n
Prev n -> modify wrapLeft >> run n
Read n -> do
focus <~ asks S.head
local S.tail $ run n
Write n -> do
tell . return =<< use focus
run n
Branch z n -> do
c <- use focus
run $ case c of 0 -> z; _ -> n
-- | Zipper helpers
wrapRight, wrapLeft :: (a :> b) -> (a :> b)
wrapRight = liftM2 fromMaybe leftmost rightward
wrapLeft = liftM2 fromMaybe rightmost leftward
-- Main program action to actually run this stuff
main :: IO ()
main = do
as <- getArgs
case as of
-- STDIN is program
[ ] -> do
hSetBuffering stdin NoBuffering
hSetBuffering stdout NoBuffering
getContents >>= eval noInput
-- STDIN is input
[f] -> join $ eval <$> getInput <*> readFile f
-- Malformed command line
_ -> putStrLn "Usage: brainfuck [program]"
eval :: Input -> String -> IO ()
eval i = mapM_ putByte . interpret i . compile . parse
where putByte = BS.putStr . BS.pack . return
-- | EOF is represented as 0
getInput :: IO Input
getInput = f <$> BS.getContents
where f s = S.fromList (BS.unpack s ++ repeat 0)
noInput :: Input
noInput = S.repeat 0
Something went wrong with that request. Please try again.