128 lines
5 KiB
Haskell
128 lines
5 KiB
Haskell
{-# LANGUAGE ImportQualifiedPost #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
|
|
-- | This module allows you to parse and manipulate brainfuck programs. Currently there are no re-exports here, you may need to look into submodules to find the operations you need.
|
|
|
|
module Language.Brainfuck (parse, ParseFailure(..), render) where
|
|
|
|
import Control.Monad.ST (runST, ST)
|
|
|
|
import Data.Text ( Text )
|
|
import Data.Vector (MVector, Vector)
|
|
|
|
import Data.Text qualified as Text
|
|
import Data.Vector qualified as Vector
|
|
import Data.Vector.Mutable qualified as MutableVector
|
|
|
|
import Language.Brainfuck.Instruction ( Instruction(..) )
|
|
import qualified Data.List as List
|
|
import Numeric.Natural (Natural)
|
|
|
|
-- | Brainfuck has only two types of syntax errors: either too many open brackets or too many closed brackets, this is the failure type.
|
|
|
|
data ParseFailure
|
|
= UnexpectedClosingBracket Natural
|
|
-- ^ closing bracket position
|
|
| UnmatchedOpenBracket Natural
|
|
-- ^ opening bracket position
|
|
deriving stock (Show, Eq)
|
|
|
|
-- | Convert a Text to a list of instructions, discard all comments.
|
|
--
|
|
-- Recognized instructions are in the string "+-<>,.[]", they are represented as a Enum Type.
|
|
--
|
|
-- ==== __Examples__
|
|
--
|
|
-- >>> parse $ Text.pack "<<>>,,..<,.>"
|
|
-- Right [MoveLeft,MoveLeft,MoveRight,MoveRight,ReadByte,ReadByte,PutByte,PutByte,MoveLeft,ReadByte,PutByte,MoveRight]
|
|
--
|
|
-- >>> parse $ Text.pack "[-]++<<<[>-[+-+-+]]>+"
|
|
-- Right [Loop [Decrement],Increment,Increment,MoveLeft,MoveLeft,MoveLeft,Loop [MoveRight,Decrement,Loop [Increment,Decrement,Increment,Decrement,Increment]],MoveRight,Increment]
|
|
--
|
|
-- >>> parse $ Text.pack "["
|
|
-- Left (UnmatchedOpenBracket 0)
|
|
--
|
|
-- >>> parse $ Text.pack "[]]"
|
|
-- Left (UnexpectedClosingBracket 2)
|
|
|
|
parse :: Text -> Either ParseFailure (Vector Instruction)
|
|
parse text = runST $ do
|
|
collectorVector <- MutableVector.new (Text.length text)
|
|
|
|
result <- parseBlock text collectorVector 0
|
|
|
|
pure $ case result of
|
|
|
|
Right (instructions, rest) -> case rest of
|
|
Text.Empty -> Right instructions
|
|
_ -> Left (UnexpectedClosingBracket . fromIntegral $ Text.length text - Text.length rest)
|
|
|
|
Left failure -> Left failure
|
|
|
|
where
|
|
|
|
-- | Parses the supplied text until the next closing bracket., the closing bracket will be returned in the rest.
|
|
--
|
|
-- Assumes the vector has enough space to hold all the instructions. Assumes all elements until the Int index have already been initialized.
|
|
parseBlock :: Text -> MVector s Instruction -> Int -> ST s (Either ParseFailure (Vector Instruction, Text))
|
|
parseBlock Text.Empty instructions index = do
|
|
let populatedSlice = MutableVector.take index instructions
|
|
frozen <- Vector.freeze populatedSlice
|
|
pure . Right $ (frozen, Text.empty)
|
|
parseBlock t@(c Text.:< cs) instructions index = let
|
|
|
|
recognizeInstruction i cont = do
|
|
MutableVector.write instructions index i
|
|
parseBlock cont instructions (succ index)
|
|
|
|
in case c of
|
|
'+' -> recognizeInstruction Increment cs
|
|
'-' -> recognizeInstruction Decrement cs
|
|
'>' -> recognizeInstruction MoveRight cs
|
|
'<' -> recognizeInstruction MoveLeft cs
|
|
',' -> recognizeInstruction ReadByte cs
|
|
'.' -> recognizeInstruction PutByte cs
|
|
']' -> do
|
|
let populatedSlice = MutableVector.take index instructions
|
|
frozen <- Vector.freeze populatedSlice
|
|
pure $ Right (frozen, t)
|
|
'[' -> do
|
|
innerVector <- MutableVector.new (Text.length cs)
|
|
innerResult <- parseBlock cs innerVector 0
|
|
case innerResult of
|
|
Right (body, ']' Text.:< rest) -> recognizeInstruction (Loop body) rest
|
|
Right _ -> pure $ Left (UnmatchedOpenBracket . fromIntegral $ Text.length text - Text.length t)
|
|
_ -> pure innerResult
|
|
_ -> parseBlock cs instructions index
|
|
|
|
-- | Render a series of instructions into a program text.
|
|
--
|
|
-- This is not exactly an inverse of 'parse' because parse will discard all comments and may fail with the 'Left' constructor.
|
|
--
|
|
-- ==== __Examples__
|
|
--
|
|
-- >>> render $ Vector.fromList [Increment,Increment, Loop $ Vector.fromList [Decrement, MoveRight, Increment, MoveLeft]]
|
|
-- "++[->+<]"
|
|
--
|
|
-- >>> fmap render . parse $ Text.pack "++ [ ->+< ] comment"
|
|
-- Right "++[->+<]"
|
|
|
|
render :: Vector Instruction -> Text
|
|
render = Text.concat . List.map renderSingle . Vector.toList
|
|
where
|
|
renderSingle = \case
|
|
Increment -> Text.singleton '+'
|
|
Decrement -> Text.singleton '-'
|
|
MoveLeft -> Text.singleton '<'
|
|
MoveRight -> Text.singleton '>'
|
|
ReadByte -> Text.singleton ','
|
|
PutByte -> Text.singleton '.'
|
|
Loop body -> Text.concat [Text.singleton '[', render body, Text.singleton ']']
|
|
|
|
-- >>> import Test.QuickCheck.Instances.Vector ()
|
|
-- >>> import Test.QuickCheck.Arbitrary (arbitrary)
|
|
-- >>> import Test.QuickCheck.Gen as Gen
|
|
-- >>> render <$> Gen.generate arbitrary
|
|
-- "-<,.<<,>++.[]<+>.<.-,"
|
|
|