From 2fc0d46ee9c3b44ad328ea1b21e5e1650c537d7e Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Fri, 27 Jun 2025 16:19:59 +0200 Subject: [PATCH 1/4] fix: doc code comment --- src/Language/Brainfuck.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Language/Brainfuck.hs b/src/Language/Brainfuck.hs index c348315..ffcbb42 100644 --- a/src/Language/Brainfuck.hs +++ b/src/Language/Brainfuck.hs @@ -100,6 +100,7 @@ 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 --- "<,<>,<,." +-- "-<,.<<,>++.[]<+>.<.-," From 7705371b6b88cbe29a71ecf63d40785b45712243 Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Fri, 27 Jun 2025 16:20:39 +0200 Subject: [PATCH 2/4] feat: Natural instead of Ints for nonnegativity --- src/Language/Brainfuck.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Language/Brainfuck.hs b/src/Language/Brainfuck.hs index ffcbb42..040ef7e 100644 --- a/src/Language/Brainfuck.hs +++ b/src/Language/Brainfuck.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} module Language.Brainfuck (parse, ParseFailure, render) where @@ -16,10 +15,11 @@ 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 Int -- closing bracket position - | UnmatchedOpenBracket Int -- opening bracket position + = 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. @@ -36,19 +36,19 @@ parse text = runST $ do Right (instructions, rest) -> case rest of Text.Empty -> Right instructions - _ -> Left (UnexpectedClosingBracket $ Text.length text - Text.length rest) + _ -> Left (UnexpectedClosingBracket . fromIntegral $ Text.length text - Text.length rest) Left failure -> Left failure where go :: Text -> MVector s Instruction -> Int -> ST s (Either ParseFailure (Vector Instruction, Text)) - go (Text.Empty ) instructions index = do + go Text.Empty instructions index = do let populatedSlice = MutableVector.take index instructions frozen <- Vector.force <$!> Vector.freeze populatedSlice pure . Right $ (frozen, Text.empty) go t@(c Text.:< cs) instructions index = let - + recognizeInstruction i cont = do MutableVector.write instructions index i go cont instructions (succ index) @@ -69,7 +69,7 @@ parse text = runST $ do 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) + Right _ -> pure $ Left (UnmatchedOpenBracket . fromIntegral $ Text.length text - Text.length t) _ -> pure innerResult _ -> go cs instructions index From a94455f365438cacfa354d58269536019fdefd16 Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Fri, 27 Jun 2025 16:21:38 +0200 Subject: [PATCH 3/4] change the compiler version for better HLS support --- stack.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/stack.yaml b/stack.yaml index c092d1d..8e55f30 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,6 +18,7 @@ # 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. From f9fd24261acb06c23df5384492c0c3b8bc9dfc5a Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Fri, 27 Jun 2025 16:23:38 +0200 Subject: [PATCH 4/4] fix: function naming --- src/Language/Brainfuck.hs | 55 +++++++++++++++++++++------------------ 1 file changed, 29 insertions(+), 26 deletions(-) diff --git a/src/Language/Brainfuck.hs b/src/Language/Brainfuck.hs index 040ef7e..0681be7 100644 --- a/src/Language/Brainfuck.hs +++ b/src/Language/Brainfuck.hs @@ -30,7 +30,7 @@ parse :: Text -> Either ParseFailure (Vector Instruction) parse text = runST $ do collectorVector <- MutableVector.new (Text.length text) - result <- go text collectorVector 0 + result <- parseBlock text collectorVector 0 pure $ case result of @@ -42,36 +42,39 @@ parse text = runST $ do where - go :: Text -> MVector s Instruction -> Int -> ST s (Either ParseFailure (Vector Instruction, Text)) - go Text.Empty instructions index = do + -- | 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.force <$!> Vector.freeze populatedSlice pure . Right $ (frozen, Text.empty) - go t@(c Text.:< cs) instructions index = let + parseBlock 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 <- go 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 - _ -> go 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 <- 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 -- >>> parse $ Text.pack "<<>>,,..<,.>"