{-# 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
-- "-<,.<<,>++.[]<+>.<.-,"