I already did a lot of things

src/Language/Brainfuck.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DerivingStrategies #-}
+module Language.Brainfuck (parse, ParseFailure) where
+
+import Control.Monad ((<$!>))
+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(..) )
+
+data ParseFailure
+  = UnexpectedClosingBracket Int -- closing bracket position
+  | UnmatchedOpenBracket Int -- opening bracket position
+  deriving stock (Show)
+
+-- | Convert a Text to a list of instructions, discard all comments.
+--
+-- Recognized instructions are in the string "+-<>,.[]", they are represented as a Enum Type.
+
+parse :: Text -> Either ParseFailure (Vector Instruction)
+parse text = runST $ do
+  collectorVector <- MutableVector.new (Text.length text)
+
+  result <- go text collectorVector 0
+
+  pure $ case result of
+
+    Right (instructions, rest) -> case rest of
+      Text.Empty -> Right instructions
+      _ -> Left (UnexpectedClosingBracket $ 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
+      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)
+
+      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 "<<>>,,..<,.>"
+-- 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)

src/Language/Brainfuck/Instruction.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE DerivingStrategies #-}
+module Language.Brainfuck.Instruction (Instruction(..)) where
+
+import Data.Vector ( Vector )
+
+data Instruction
+  = Increment
+  | Decrement
+  | MoveLeft
+  | MoveRight
+  | ReadByte
+  | PutByte
+  | Loop (Vector Instruction)
+  deriving stock (Show, Eq)

src/Language/Brainfuck/Instruction/Compressed.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+module Language.Brainfuck.Instruction.Compressed ( CompressedInstruction(..), compress ) where
+
+import Data.Bifunctor ( Bifunctor(first) )
+import Data.Vector ( Vector )
+import Data.Word ( Word8 )
+import Numeric.Natural ( Natural )
+
+import Data.Vector qualified as Vector
+
+import Language.Brainfuck.Instruction ( Instruction )
+import Language.Brainfuck.Instruction qualified as Instruction 
+
+data CompressedInstruction
+  = Add Word8
+  | Subtract Word8
+  | MoveRight Natural
+  | MoveLeft Natural
+  | ReadByte
+  | PutByte
+  | Loop (Vector CompressedInstruction)
+  deriving (Show, Eq)
+
+compress :: Vector Instruction -> Vector CompressedInstruction
+compress instructions = Vector.fromList (go instructions)
+  where
+    go program = case Vector.uncons program of
+      Nothing -> []
+      Just (x, rest) -> let
+
+        withRepeatCount f = let (count, rest') = spanLength x rest
+          in (f . fromIntegral . succ) count : go rest'
+          
+        in case x of
+          Instruction.Increment  -> withRepeatCount Add
+          Instruction.Decrement  -> withRepeatCount Subtract
+          Instruction.MoveRight  -> withRepeatCount MoveRight
+          Instruction.MoveLeft   -> withRepeatCount MoveLeft
+          Instruction.ReadByte   -> ReadByte : go rest
+          Instruction.PutByte    -> PutByte : go rest
+          Instruction.Loop inner -> Loop (compress inner) : go rest
+
+    spanLength :: Eq a => a -> Vector a -> (Int, Vector a)
+    spanLength x xs = first Vector.length $ Vector.span (== x) xs
+
+-- >>> fromInteger 300 :: Word8
+-- 44
+
+-- >>> compress . Vector.fromList $ replicate 300 Instruction.Increment
+-- [Add 44]
+-- >>> compress . Vector.fromList $ replicate 300 Instruction.MoveRight
+-- [MoveRight 300]
+

src/Language/Brainfuck/Instruction/Extended.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternSynonyms #-}
+module Language.Brainfuck.Instruction.Extended (Operation(..), Interaction(..), ExtendedInstruction(Modify, Move, Interact, Jump), pattern IfNonZero, pattern WithOffset, mkIfNonZero, mkWithOffset, translationSize, parse) where
+import Data.Word (Word8)
+import Language.Brainfuck.Instruction.Compressed (CompressedInstruction)
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+import qualified Language.Brainfuck.Instruction.Compressed as CompressedInstruction
+import Numeric.Natural (Natural)
+
+data Operation
+  = Add
+  | Subtract
+  deriving (Show)
+
+data Interaction
+  = Read
+  | Write
+  deriving (Show)
+
+pattern WithOffset :: Int -> ExtendedInstruction -> ExtendedInstruction
+pattern WithOffset offset embedded <- AtOffset offset embedded
+  where
+    WithOffset offset embedded = mkWithOffset offset embedded
+
+pattern IfNonZero :: ExtendedInstruction -> ExtendedInstruction
+pattern IfNonZero instruction <- WhenNonZero instruction
+  where
+    IfNonZero instruction = mkIfNonZero instruction
+
+data ExtendedInstruction
+  = AtOffset Int ExtendedInstruction -- invariant, WithOffset may not nest itself
+  | WhenNonZero ExtendedInstruction -- invariant, IfNonZero may not nest itself
+  | Modify Operation Word8
+  | Move Integer
+  | Interact Interaction
+  | Jump Integer
+  deriving (Show)
+
+mkIfNonZero :: ExtendedInstruction -> ExtendedInstruction
+mkIfNonZero = \case
+  WhenNonZero i -> WhenNonZero i
+  instruction -> WhenNonZero instruction
+
+mkWithOffset :: Int -> ExtendedInstruction -> ExtendedInstruction
+mkWithOffset offset = \case
+  AtOffset offset' i -> AtOffset (offset + offset') i
+  instruction -> AtOffset offset instruction
+
+-- >>> mkWithOffset 15 $ mkWithOffset (-3) $ Interact Read
+-- AtOffset 12 (Interact Read)
+
+parse :: Vector CompressedInstruction -> Vector ExtendedInstruction
+parse = Vector.fromList . Vector.foldr prependTranslation []
+
+prependTranslation :: CompressedInstruction -> [ExtendedInstruction] -> [ExtendedInstruction]
+prependTranslation instruction rest = let
+  addSingle = (:rest)
+  in case instruction of
+    CompressedInstruction.Add       i    -> addSingle $ Modify Add i
+    CompressedInstruction.Subtract  i    -> addSingle $ Modify Subtract i
+    CompressedInstruction.MoveRight n    -> addSingle $ Move $ toInteger n
+    CompressedInstruction.MoveLeft  n    -> addSingle $ Move $ toInteger (-n)
+    CompressedInstruction.ReadByte       -> addSingle $ Interact Read
+    CompressedInstruction.PutByte        -> addSingle $ Interact Write
+    CompressedInstruction.Loop      body -> let
+      bodySize = translationSize body
+      backJump = IfNonZero $ Jump $ -(toInteger bodySize + 1)
+      forwardJump = Jump $ toInteger bodySize
+
+      in forwardJump : Vector.foldr prependTranslation (backJump : rest) body
+
+translationSize :: Vector CompressedInstruction -> Natural
+translationSize = Vector.sum . Vector.map instructionTranslationSize
+  where
+    instructionTranslationSize = \case
+     CompressedInstruction.Add       _    -> 1
+     CompressedInstruction.Subtract  _    -> 1
+     CompressedInstruction.MoveRight _    -> 1
+     CompressedInstruction.MoveLeft  _    -> 1
+     CompressedInstruction.ReadByte       -> 1
+     CompressedInstruction.PutByte        -> 1
+     CompressedInstruction.Loop      body -> let
+      skipLoopSize = 1
+      repeatLoopSize = 1
+      bodySize = translationSize body
+      in skipLoopSize + repeatLoopSize + bodySize
+
+-- >>> :set -XOverloadedLists
+-- >>> parse [CompressedInstruction.Add 5]
+-- [Modify Add 5]
+--
+-- >>> parse [CompressedInstruction.Add 5, CompressedInstruction.Loop [CompressedInstruction.Loop [CompressedInstruction.ReadByte], CompressedInstruction.PutByte]]
+-- [Modify Add 5,Jump 4,Jump 1,Interact Read,WhenNonZero (Jump (-2)),Interact Write,WhenNonZero (Jump (-5))]
+