diff --git a/src/Language/Brainfuck.hs b/src/Language/Brainfuck.hs index 0681be7..c348315 100644 --- a/src/Language/Brainfuck.hs +++ b/src/Language/Brainfuck.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} module Language.Brainfuck (parse, ParseFailure, render) where @@ -15,11 +16,10 @@ import Data.Vector.Mutable qualified as MutableVector import Language.Brainfuck.Instruction ( Instruction(..) ) import qualified Data.List as List -import Numeric.Natural (Natural) data ParseFailure - = UnexpectedClosingBracket Natural -- closing bracket position - | UnmatchedOpenBracket Natural -- opening bracket position + = UnexpectedClosingBracket Int -- closing bracket position + | UnmatchedOpenBracket Int -- opening bracket position deriving stock (Show, Eq) -- | Convert a Text to a list of instructions, discard all comments. @@ -30,51 +30,48 @@ parse :: Text -> Either ParseFailure (Vector Instruction) parse text = runST $ do collectorVector <- MutableVector.new (Text.length text) - result <- parseBlock text collectorVector 0 + result <- go 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 (UnexpectedClosingBracket $ 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 + go :: Text -> MVector s Instruction -> Int -> ST s (Either ParseFailure (Vector Instruction, Text)) + go (Text.Empty ) instructions index = do let populatedSlice = MutableVector.take index instructions frozen <- Vector.force <$!> Vector.freeze populatedSlice pure . Right $ (frozen, Text.empty) - parseBlock t@(c Text.:< cs) instructions index = let + go t@(c Text.:< cs) instructions index = let + + recognizeInstruction i cont = do + MutableVector.write instructions index i + go cont instructions (succ index) - 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.force <$!> 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 + 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.force <$!> Vector.freeze populatedSlice + pure $ Right (frozen, t) + '[' -> do + innerVector <- MutableVector.new (Text.length cs) + innerResult <- go cs innerVector 0 + case innerResult of + Right (body, ']' Text.:< rest) -> recognizeInstruction (Loop body) rest + Right _ -> pure $ Left (UnmatchedOpenBracket $ Text.length text - Text.length t) + _ -> pure innerResult + _ -> go cs instructions index -- >>> parse $ Text.pack "<<>>,,..<,.>" @@ -103,7 +100,6 @@ render = Text.concat . List.map renderSingle . Vector.toList -- >>> import Test.QuickCheck.Instances.Vector () -- >>> import Test.QuickCheck.Arbitrary (arbitrary) --- >>> import Test.QuickCheck.Gen as Gen -- >>> render <$> Gen.generate arbitrary --- "-<,.<<,>++.[]<+>.<.-," +-- "<,<>,<,." diff --git a/stack.yaml b/stack.yaml index 8e55f30..c092d1d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,7 +18,6 @@ # snapshot: ./custom-snapshot.yaml # snapshot: https://example.com/snapshots/2024-01-01.yaml snapshot: nightly-2025-06-16 -compiler: ghc-9.12.1 # User packages to be built. # Various formats can be used as shown in the example below.