diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,43 @@ +# haskell-brainfuck + +Interpreter for the +[brainfuck programming language](http://www.muppetlabs.com/~breadbox/bf/) + +[![Build Status](https://api.travis-ci.org/paraseba/haskell-brainfuck.svg?branch=master)](https://travis-ci.org/paraseba/haskell-brainfuck) + +haskel-brainfuck is distributed as a library, but it also includes an executable +to run brainfuck programs. You can find haskell-brainfuck in +[Hackage](https://hackage.haskell.org/package/haskell-brainfuck-0.1.0.0) + +## Usage +### Library +```haskell +import HaskBF.Eval +import qualified Data.ByteString.Lazy as BS +import Control.Monad.State + +main = do + -- The following will evaluate the file using stdin and stdout for I/O. + -- Evaluation results in an EvalResult + + file <- BS.readFile "/path/to/file.bf" + (EvalSuccess _) <- evalBS defaultIOMachine file + print "ok" + + + -- The following will evaluate the file using the State monad and input + -- provided by input + + let input = [] + output = [] + result = execState (evalStr simulatorMachine "+.>-.") (SimState input output) + print $ simStateOutput result == [1, -1] +``` + +### Executable +```bash +brainfuck fib.bf +``` + +## Documentation +http://paraseba.github.io/haskell-brainfuck/ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskell-brainfuck.cabal b/haskell-brainfuck.cabal new file mode 100644 --- /dev/null +++ b/haskell-brainfuck.cabal @@ -0,0 +1,62 @@ +name: haskell-brainfuck +version: 0.1.0.0 + +synopsis: BrainFuck interpreter + +description: BrainFuck language interpreter. + Provides a library for evaluation and an executable to evaluate + brainfuck files. Evaluation happens under an arbitrary monad so + programn can be evaluated doing I/O to stdin/stdout or in memory + using the State monad. + +license: MIT +license-file: LICENSE + +author: Sebastian Galkin +maintainer: Sebastian Galkin + +copyright: (c) 2014 Sebastian Galkin + +category: Language +build-type: Simple +extra-source-files: README.md + +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/paraseba/haskell-brainfuck + +library + exposed-modules: + HaskBF.Parser, HaskBF.Tape, HaskBF.Eval + hs-source-dirs: src/ + build-depends: base >=4.7 && <4.8 + ,bytestring==0.10.4.0 + ,parsec==3.1.5 + ,mtl==2.1.3.1 + default-extensions: TupleSections + default-language: Haskell2010 + ghc-options: -Wall -fwarn-tabs -fno-warn-unused-do-bind -fno-warn-deprecated-flags + -funbox-strict-fields + +executable brainfuck + main-is: src/Main.hs + build-depends: base >=4.7 && <4.8 + , bytestring==0.10.4.0 + , haskell-brainfuck + default-language: Haskell2010 + + +Test-Suite test + type: exitcode-stdio-1.0 + main-is: test.hs + default-language: Haskell2010 + hs-source-dirs: tests + build-depends: base >=4.7 && <4.8 + , haskell-brainfuck + , bytestring==0.10.4.0 + , mtl==2.1.3.1 + , tasty==0.8.1.3 + , tasty-quickcheck==0.8.1 + , QuickCheck==2.7.5 diff --git a/src/HaskBF/Eval.hs b/src/HaskBF/Eval.hs new file mode 100644 --- /dev/null +++ b/src/HaskBF/Eval.hs @@ -0,0 +1,193 @@ +{- | +Module : HaskBF.Eval +Description : Evaluate a BrainFuck program +Copyright : (c) Sebastian Galkin, 2014 +License : MIT +Maintainer : paraseba@gmail.com +Stability : experimental + +This module exports functions that allow to evaluate a BrainFuck program. +Evaluation supports two types of error, parsing and execution, by returning +instances of 'EvalResult' + +This module should be all library users need to import. +-} + +module HaskBF.Eval ( + eval, evalBS, evalStr + , EvalResult (..) + , Machine (..) + , defaultIOMachine + , simulatorMachine, SimState (SimState), simStateOutput + , emptyState + + , module HaskBF.Tape + , module HaskBF.Parser +) where + +import Data.Int + ( Int8 ) + +import Control.Monad + ( liftM, when ) + +import Control.Monad.State + ( State, modify, state, StateT ( StateT ), execStateT, get) + +import Control.Monad.Error + ( ErrorT ( ErrorT ), runErrorT ) + +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BSC + +import qualified HaskBF.Parser as P + +import HaskBF.Parser + ( ParseError ) + +import HaskBF.Tape + ( Tape ( Tape ), blankTape, BFTape, BFExError, errMsg + , errTape, rTape, wTape, left, right, inc, dec) + +type ExecutionState m = StateT BFTape (ErrorT BFExError m) + +{- | Underlying input output for the evaluation machine. Changing the monad 'm' + - achives different results. For instance using the 'IO' monad an evaluator can + - be created that does input/output to stdin/stdout. If the monad is 'State', + - for instance, input/output can happen in memory. + - + - We offer two implementations of 'Machine': + - + - * 'defaultIOMachine': under the 'IO' monad, does input/output using the + - standard streams + - * 'simulatorMachine': under the 'State' monad, does input/output on lists + - + - It's easy to create other 'Machine's by using different monads and + - functions. -} +data Machine m = + Machine { putByte :: Int8 -> m () -- ^ Write a byte to the output, under + -- monad 'm' + , getByte :: m Int8 -- ^ Get a byte under the 'm' monad + } + +evalTape :: Monad m + => Machine m + -> P.Program + -> ExecutionState m () +evalTape m = mapM_ (evalOp m) + + +{- | Evaluate a parsed BrainFuck program using I/O provided by the given + - 'Machine' + - + - The result is either an execution error or the 'BFTape' representing the + - resulting state of the tape after the last instruction was executed. -} +eval :: Monad m + => Machine m -- ^ The machine used to do I/O + -> P.Program -- ^ The program to evaluate + -> m (Either BFExError BFTape) -- ^ Resulting tape after evaluation or + -- execution error +eval m p = runErrorT $ execStateT (evalTape m p) blankTape + +-- | Evaluation result of an unparsed BrainFuck program +data EvalResult = EvalSuccess BFTape + {- ^ Parsing and evaluation were successful. The resulting + - state of the tape after the last instruction + - was executed. -} + + | EvalExecError BFExError + {- ^ The program was parsed successfully but evaluation + - failed. + - The reason for failure is overflowing a limit of the tape. + - The state of the tape before the error is included -} + + | EvalParseError ParseError + {- ^ The program can not be parsed. Parsing error message is + - included -} + +{- | Evaluate an unparsed BrainFuck program using I/O provided by the given + - 'Machine' + - + - The result is returned as an 'EvalResult' -} +evalBS :: Monad m + => Machine m -- ^ The machine used to do I/O + -> BS.ByteString -- ^ The code to evaluate + -> m EvalResult -- ^ Parsing/evaluation result +evalBS machine program = + either parseError evaluate . P.parseProgram $ program + where parseError = return . EvalParseError + evaluate = liftM (either EvalExecError EvalSuccess) . eval machine + +{- | Evaluate an unparsed BrainFuck program using I/O provided by the given + - 'Machine' + - + - The result is returned as an 'EvalResult' -} +evalStr :: Monad m + => Machine m -- ^ The machine used to do I/O + -> String -- ^ The code to evaluate + -> m EvalResult -- ^ Parsing/evaluation result +evalStr m = evalBS m . BSC.pack + +evolve :: Monad m + => (BFTape -> m (Either BFExError BFTape)) + -> ExecutionState m () +evolve g = StateT $ ErrorT . (>>= return . liftM ((),)) . g + +evalOp :: Monad m + => Machine m + -> P.Op + -> ExecutionState m () + +evalOp _ P.IncP = evolve $ return . right +evalOp _ P.DecP = evolve $ return . left +evalOp _ P.Inc = evolve $ return . Right . inc +evalOp _ P.Dec = evolve $ return . Right . dec + +evalOp ( Machine { putByte = putB } ) P.PutByte = + evolve $ \ tape -> liftM ( const ( Right tape ) ) $ ( putB . rTape ) tape + +evalOp ( Machine {getByte = getB } ) P.GetByte = + evolve $ \ tape -> liftM ( Right . flip wTape tape ) getB + +evalOp machine (P.Loop ops) = do + tape <- get + when (rTape tape /= 0) $ + evalTape machine ops >> evalOp machine (P.Loop ops) + + +{- | A 'Machine' that can evaluate code under the 'IO' monad by doing I/O + - to stdin/stout. + - + - Bytes are read by comnverting them from the ASCII code -} +defaultIOMachine :: Machine IO +defaultIOMachine = Machine (putChar . toEnum . fromIntegral) + (fmap (fromIntegral . fromEnum) getChar) + +{- | State used by 'simulatorMachine' to evaluate code under the 'State' monad + - + - It maintains input and output bytes inside lists -} +data SimState = + SimState {input :: [Int8], -- ^ Input bytes to use when the program + -- does @ "," @ + output :: [Int8] -- ^ Store for the program outputs done with + -- @ "." @ + } + +-- | Extract the output stream from a 'simulatorMachine' state +simStateOutput :: SimState -> [Int8] +simStateOutput = reverse . output + +-- | Initial 'simulatorMachine' state +emptyState :: SimState +emptyState = SimState [] [] + +{- | A 'Machine' that can evaluate program doing in-memory I/O under the 'State' + - monad. It stores state as 'SimState' -} +simulatorMachine :: Machine (State SimState) +simulatorMachine = + Machine (modify . writeByte) + (state readByte) + where writeByte byte s@(SimState {output = o} ) = s {output = byte : o} + readByte s@(SimState {input = (byte : rest)}) = (byte, s {input = rest}) + readByte _ = error "Not enough input available" + diff --git a/src/HaskBF/Parser.hs b/src/HaskBF/Parser.hs new file mode 100644 --- /dev/null +++ b/src/HaskBF/Parser.hs @@ -0,0 +1,85 @@ +{-# OPTIONS_HADDOCK show-extensions #-} + +{- | +Module : HaskBF.Parser +Description : Parse brainfuck program into a Program abstract datatype +Copyright : (c) Sebastian Galkin, 2014 +License : MIT +Maintainer : paraseba@gmail.com +Stability : experimental + +-} + +module HaskBF.Parser ( + Program + , Op (..) + , parseProgram + , module Text.Parsec.Error + ) where + +import Text.Parsec.Prim + ( (<|>), runP, skipMany ) + +import Text.Parsec.Combinator + ( between, sepEndBy, eof ) + +import Text.Parsec.Error + ( ParseError ) + +import Text.Parsec.ByteString.Lazy + ( Parser ) + +import Text.Parsec.Char + ( space, spaces, char ) + +import Control.Applicative + ( (<*), (<$>) ) + +import qualified Data.ByteString.Lazy as BS + +-- | Brainfuck operations +data Op + = IncP -- ^ Increment the byte pointer: @ ">" @ + | DecP -- ^ Decrement the byte pointer: @ "<" @ + | Inc -- ^ Increment the byte pointed by the pointer: @ "+" @ + | Dec -- ^ Decrement the byte pointed by the pointer: @ "-" @ + | PutByte -- ^ Write the byte pointed by the pointer (side-effect): @ "." @ + | GetByte -- ^ Read a byte, write at the current location + -- (side-effect): @ "," @ + | Loop [Op] -- ^ Loop over 'Op's untill current @ == 0 @: @ "[...]" @ + deriving (Show, Eq) + +-- | A program is a list of 'Op's. One possible 'Op' is a 'Loop' of other 'Op's +type Program = [Op] + +program :: Parser Program +program = do + skipMany space + sepEndBy operation spaces + +fullProgram :: Parser Program +fullProgram = program <* eof + +operation :: Parser Op +operation = simpleOp <|> loop + +simpleChar :: Parser Char +simpleChar = (char '>') <|> (char '<') <|> (char '+') <|> + (char '-') <|> (char '.') <|> (char ',') + +simpleOp :: Parser Op +simpleOp = fmap build simpleChar + where build '>' = IncP + build '<' = DecP + build '+' = Inc + build '-' = Dec + build '.' = PutByte + build ',' = GetByte + build _ = error "Unknown character" -- this should never happen + +loop :: Parser Op +loop = Loop <$> between (char '[') (char ']') program + +-- | Parse program stream. Returns an error or the parsed 'Program' +parseProgram :: BS.ByteString -> Either ParseError Program +parseProgram = runP fullProgram () "" diff --git a/src/HaskBF/Tape.hs b/src/HaskBF/Tape.hs new file mode 100644 --- /dev/null +++ b/src/HaskBF/Tape.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE FlexibleInstances #-} + +{- | +Module : HaskBF.Tape +Description : Implement the brainfuck tape +Copyright : (c) Sebastian Galkin, 2014 +License : MIT +Maintainer : paraseba@gmail.com +Stability : experimental + +Provides a type and operations to implement the brainfuck tape. The tape has +the concept of a pointer, and the pointer can be incremented or decremented. + +-} + +module HaskBF.Tape ( + Tape (Tape) + , ExecutionError (errMsg, errTape) + , rTape, wTape + , inc, dec + , right, left + , BFExError + , BFTape + , blankTape +) where + +import Data.Int + ( Int8 ) +import Control.Monad.Error + ( Error, strMsg ) + +{- | Brainfuck tape. Constructor arguments correspond to + - + - 1. left of the current pointer + - 2. current pointed value + - 3. right of the current pointer + - + - The left part of the tape is reversed, so the first element of the list + - is the rightmost position. The right list is normal order, its first element + - is the leftmost one. -} +data Tape t = Tape [t] t [t] + deriving (Show) + +-- | Write element to the current position in the tape +wTape :: t -- ^ The element to write + -> Tape t -- ^ The tape + -> Tape t -- ^ The modified tape +wTape b (Tape l _ r) = Tape l b r + +-- | Read the pointed element +rTape :: Tape t -- ^ The tape + -> t -- ^ The element currently pointed by the pointer +rTape (Tape _ current _) = current + +update :: (t -> t) -> Tape t -> Tape t +update f t = wTape (f $ rTape t) t + +-- | Increment the currently pointed element +inc :: Num a + => Tape a -- ^ The tape + -> Tape a -- ^ The tape with the current position incremented +inc = update (+ 1) + +-- | Decrement the currently pointed element +dec :: Num a + => Tape a -- ^ The tape + -> Tape a -- ^ The tape with the current position decremented +dec = update (+ (- 1)) + +{- | Type for execution errors, trying to move the tape beyond one of its + - ends. The 'String' argument is the error message and the 'Tape' is in + - the state right before the faulting operation -} +data ExecutionError a = ExecutionError {errMsg :: String, errTape :: Tape a} + +-- | Move the pinter to the right +right :: Tape a -- ^ The tape + -> Either (ExecutionError a) (Tape a) + {- ^ A new tape with its pointer pointing to the + - element to the right of the pointer in the + - original tape; or an execution error if the + - tape to the right is exhausted -} +right t@(Tape _ _ []) = + Left $ ExecutionError "Error trying to go right on an empty tape" t + +right (Tape l c (r : rs)) = Right $ Tape (c : l) r rs + +-- | Move the pinter to the left +left :: Tape a -- ^ The tape + -> Either (ExecutionError a) (Tape a) + {- ^ A new tape with its pointer pointing to + - the element to the left of the pointer in + - the original tape; or an execution error if + - the tape to the left is exhausted -} +left t@(Tape [] _ _) = + Left $ ExecutionError "Error trying to go left on an empty tape" t + +left (Tape (l : ls) c r) = Right $ Tape ls l (c : r) + +constTape :: t -> Tape t +constTape b = Tape [] b (repeat b) + +-- | Execution error type for basic Brainfuck tapes +type BFExError = ExecutionError Int8 + +-- | Brainfuck tapes type +type BFTape = Tape Int8 + +instance Error BFExError where + strMsg s = ExecutionError s (Tape [] 0 []) + +{- | A @(0 :: 'Int8')@ initialized, infinite 'Tape' pointing to its + - leftmost position. An attemp to move the pointer left will result + - in an error -} +blankTape :: BFTape +blankTape = constTape 0 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,76 @@ +{- | +Module : Main +Description : Evaluate a BrainFuck program +Copyright : (c) Sebastian Galkin, 2014 +License : MIT +Maintainer : paraseba@gmail.com +Stability : experimental + +Usage: + +> brainfuck path/to/program.bf + +It will parse the program and evaluate it by doing I/O to the console. In case +of parsing or execution errors it reports them to stderr + +-} + +module Main(main) where + +import HaskBF.Eval + ( evalBS, EvalResult ( EvalSuccess, EvalExecError, EvalParseError ) + , defaultIOMachine, BFExError, Tape ( Tape ), BFTape, errMsg, errTape, rTape ) + +import System.Exit + ( ExitCode (..), exitWith ) + +import System.Environment + ( getArgs, getProgName ) + +import qualified Data.ByteString.Lazy as BS + +main :: IO ExitCode +main = + getProgram >>= + BS.readFile >>= + evalBS defaultIOMachine >>= + reportResults >>= + exitWith + +{- | Read command line and obtain the path to the program. Display error message + - if missing argument -} +getProgram :: IO FilePath +getProgram = do + args <- getArgs + if length args /= 1 + then do + exe <- getProgName + error $ "Usage: " ++ exe ++ " filepath" + else return $ head args + +-- | Report result of program parsing and evaluation +reportResults :: EvalResult -> IO ExitCode + +reportResults (EvalSuccess _) = return ExitSuccess + +reportResults (EvalParseError parseError) = do + putStrLn "Error parsing program:" + print parseError + return $ ExitFailure 1 + +reportResults (EvalExecError err) = do + putStrLn $ "Error evaluating program: " ++ errMsg err + putStrLn $ "Current tape value: " ++ (show . rTape . errTape) err + putStrLn $ "Consumed tape: " ++ (showConsumed . errTape) err + return $ ExitFailure 2 + +{- | Use heuristic to display tape state. It estimates consumed right tape by + - calling 'consumed' -} +showConsumed :: BFTape -> String +showConsumed (Tape _ _ r) = + "[" ++ concatMap ( (++ ",") . show ) (consumed r ++ [0, 0, 0]) ++ "..." + +-- | Return consumed tape by assuming that it is unused after 10 zeros. +consumed :: (Eq a, Num a) => [a] -> [a] +consumed (0 : 0 : 0 : 0 : 0 : 0 : 0 : 0 : 0 : 0 : _) = [] +consumed (x : xs) = x : consumed xs diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,31 @@ + +{-main :: IO ()-} +{-main = do-} + {-Test.Parser.tests-} + +import Test.Tasty +import Test.Tasty.QuickCheck as QC +import Test.QuickCheck (Testable) + +import Data.List +import Data.Ord + +import qualified Test.Parser +import qualified Test.Tape +import qualified Test.Eval + +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [properties] + +properties :: TestTree +properties = testGroup "Properties" qcProps + +mkGroup :: Testable prop => TestName -> [(TestName, prop)] -> TestTree +mkGroup name tests = testGroup name $ map (uncurry QC.testProperty) tests + +qcProps = [mkGroup "Parser" Test.Parser.properties + ,mkGroup "Tape" Test.Tape.properties + ,mkGroup "Eval" Test.Eval.properties + ]