first commit
This commit is contained in:
210
app/Main.hs
Normal file
210
app/Main.hs
Normal file
@@ -0,0 +1,210 @@
|
||||
{-# LANGUAGE GHC2021 #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Arrow ((>>>))
|
||||
import Control.Monad (void)
|
||||
import Data.Bits (shiftR, (.&.))
|
||||
import Data.ByteArray qualified as BA
|
||||
import Data.Char (chr, ord)
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int8)
|
||||
import Data.Kind (Type)
|
||||
import Data.Vector qualified as V
|
||||
import Data.Vector.Storable.Mutable qualified as MV
|
||||
import Data.Word (Word16, Word8)
|
||||
import Foreign.Ptr (Ptr, castPtr, minusPtr, plusPtr)
|
||||
import Foreign.Storable qualified as S
|
||||
import System.Environment (getArgs, getProgName)
|
||||
import System.Exit (exitFailure)
|
||||
import System.IO qualified as IO
|
||||
import Text.ParserCombinators.ReadP qualified as P
|
||||
|
||||
class Interpreter a where
|
||||
data Program a :: Type
|
||||
parse :: String -> Program a
|
||||
interpret :: Memory -> Program a -> IO ()
|
||||
|
||||
newtype Memory = Memory {unMemory :: MV.IOVector Int8}
|
||||
type MemIdx = Int
|
||||
|
||||
newMemory :: Int -> IO Memory
|
||||
newMemory = fmap Memory . MV.new
|
||||
|
||||
memorySize :: Memory -> Int
|
||||
memorySize = MV.length . unMemory
|
||||
|
||||
readMemory :: Memory -> MemIdx -> IO Int8
|
||||
readMemory = MV.unsafeRead . unMemory
|
||||
|
||||
writeMemory :: Memory -> MemIdx -> Int8 -> IO ()
|
||||
writeMemory = MV.unsafeWrite . unMemory
|
||||
|
||||
modifyMemory :: Memory -> (Int8 -> Int8) -> MemIdx -> IO ()
|
||||
modifyMemory = MV.unsafeModify . unMemory
|
||||
|
||||
nextMemoryIndex :: Memory -> MemIdx -> MemIdx
|
||||
nextMemoryIndex memory memIdx = (memIdx + 1) `mod` memorySize memory
|
||||
|
||||
prevMemoryIndex :: Memory -> MemIdx -> MemIdx
|
||||
prevMemoryIndex memory memIdx = (memIdx - 1) `mod` memorySize memory
|
||||
|
||||
-- StringInterpreter with char zipper
|
||||
data StringInterpreter
|
||||
|
||||
instance Interpreter StringInterpreter where
|
||||
data Program StringInterpreter = ProgramCZ CharZipper
|
||||
parse = ProgramCZ . czFromString
|
||||
interpret memory (ProgramCZ code) = interpretCharZipper memory code
|
||||
|
||||
-- the structure is [...,3,2,1,0] focus [0,1,2,3,...]
|
||||
data CharZipper = CharZipper
|
||||
{czLeft :: String, czFocus :: Maybe Char, czRight :: String}
|
||||
|
||||
czFromString :: String -> CharZipper
|
||||
czFromString = \case
|
||||
[] -> CharZipper [] Nothing []
|
||||
(x : xs) -> CharZipper [] (Just x) xs
|
||||
|
||||
czMoveLeft :: CharZipper -> CharZipper
|
||||
czMoveLeft = \case
|
||||
CharZipper [] (Just focus) right -> CharZipper [] Nothing (focus : right)
|
||||
CharZipper (x : xs) (Just focus) right -> CharZipper xs (Just x) (focus : right)
|
||||
z -> z
|
||||
|
||||
czMoveRight :: CharZipper -> CharZipper
|
||||
czMoveRight = \case
|
||||
CharZipper left (Just focus) [] -> CharZipper (focus : left) Nothing []
|
||||
CharZipper left (Just focus) (x : xs) -> CharZipper (focus : left) (Just x) xs
|
||||
z -> z
|
||||
|
||||
interpretCharZipper :: Memory -> CharZipper -> IO ()
|
||||
interpretCharZipper memory = go 0
|
||||
where
|
||||
go !memIdx !program = case czFocus program of
|
||||
Nothing -> return ()
|
||||
Just c -> case c of
|
||||
'+' -> modifyMemory memory (+ 1) memIdx >> goNext
|
||||
'-' -> modifyMemory memory (subtract 1) memIdx >> goNext
|
||||
'>' -> go (nextMemoryIndex memory memIdx) program'
|
||||
'<' -> go (prevMemoryIndex memory memIdx) program'
|
||||
',' -> do
|
||||
getChar >>= writeMemory memory memIdx . fromIntegral . ord
|
||||
goNext
|
||||
'.' -> do
|
||||
readMemory memory memIdx >>= putChar . chr . fromIntegral
|
||||
goNext
|
||||
'[' -> readMemory memory memIdx >>= \case
|
||||
0 -> go memIdx $ skipRight 1 program
|
||||
_ -> goNext
|
||||
']' -> readMemory memory memIdx >>= \case
|
||||
0 -> goNext
|
||||
_ -> go memIdx $ skipLeft 1 program
|
||||
_ -> goNext
|
||||
where
|
||||
program' = czMoveRight program
|
||||
goNext = go memIdx program'
|
||||
|
||||
skipRight :: Int -> CharZipper -> CharZipper
|
||||
skipRight !depth !program
|
||||
| depth == 0 = program'
|
||||
| otherwise = case czFocus program' of
|
||||
Nothing -> error "No matching [ while skipping the loop forward"
|
||||
Just '[' -> skipRight (depth + 1) program'
|
||||
Just ']' -> skipRight (depth - 1) program'
|
||||
_ -> skipRight depth program'
|
||||
where
|
||||
program' = czMoveRight program
|
||||
|
||||
skipLeft :: Int -> CharZipper -> CharZipper
|
||||
skipLeft !depth !program
|
||||
| depth == 0 = czMoveRight program
|
||||
| otherwise = case czFocus program' of
|
||||
Nothing -> error "No matching ] while skipping the loop backward"
|
||||
Just ']' -> skipLeft (depth + 1) program'
|
||||
Just '[' -> skipLeft (depth - 1) program'
|
||||
_ -> skipLeft depth program'
|
||||
where
|
||||
program' = czMoveLeft program
|
||||
|
||||
-- AST
|
||||
data ASTInterpreter
|
||||
instance Interpreter ASTInterpreter where
|
||||
data Program ASTInterpreter = ProgramAST Instructions
|
||||
parse = ProgramAST . parseToInstructions
|
||||
interpret memory (ProgramAST instrs) = interpretAST memory instrs
|
||||
|
||||
type Instructions = V.Vector Instruction
|
||||
data Instruction
|
||||
= Inc -- +
|
||||
| Dec -- -
|
||||
| MoveR -- >
|
||||
| MoveL -- <
|
||||
| GetC -- ,
|
||||
| PutC -- .
|
||||
| Loop Instructions -- []
|
||||
deriving (Show)
|
||||
|
||||
parseToInstructions :: String -> Instructions
|
||||
parseToInstructions code =
|
||||
V.fromList $ case P.readP_to_S (P.many instrParser <* P.eof) code of
|
||||
[(res, "")] -> res
|
||||
out -> error $ "Unexpected output while parsing: " <> show out
|
||||
where instrParser = P.choice
|
||||
[
|
||||
P.char '+' $> Inc,
|
||||
P.char '-' $> Dec,
|
||||
P.char '>' $> MoveR,
|
||||
P.char '<' $> MoveL,
|
||||
P.char ',' $> GetC,
|
||||
P.char '.' $> PutC,
|
||||
Loop . V.fromList <$> P.between (P.char '[') (P.char ']') (P.many instrParser)
|
||||
]
|
||||
|
||||
interpretAST :: Memory -> Instructions -> IO ()
|
||||
interpretAST memory = void . interpretInstrs 0 memory
|
||||
|
||||
interpretInstrs :: MemIdx -> Memory -> Instructions -> IO MemIdx
|
||||
interpretInstrs memIdx !memory !program = go memIdx 0
|
||||
where
|
||||
go !memIdx !progIdx
|
||||
| progIdx == V.length program = return memIdx
|
||||
| otherwise = case program V.! progIdx of
|
||||
Inc -> modifyMemory memory (+ 1) memIdx >> goNext
|
||||
Dec -> modifyMemory memory (subtract 1) memIdx >> goNext
|
||||
MoveR -> go (nextMemoryIndex memory memIdx) $ progIdx + 1
|
||||
MoveL -> go (prevMemoryIndex memory memIdx) $ progIdx + 1
|
||||
GetC -> do
|
||||
getChar >>= writeMemory memory memIdx . fromIntegral . ord
|
||||
goNext
|
||||
PutC -> do
|
||||
readMemory memory memIdx >>= putChar . chr . fromIntegral
|
||||
goNext
|
||||
Loop instrs -> readMemory memory memIdx >>= \case
|
||||
0 -> goNext
|
||||
_ -> interpretInstrs memIdx memory instrs >>= flip go progIdx
|
||||
where
|
||||
goNext = go memIdx $ progIdx + 1
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
IO.hSetBuffering IO.stdin IO.NoBuffering
|
||||
IO.hSetBuffering IO.stdout IO.LineBuffering
|
||||
progName <- getProgName
|
||||
let usage = "Usage: " <> progName <> " -(s|a|b|o) <bf_file>"
|
||||
getArgs >>= \case
|
||||
[interpreterType, fileName] -> do
|
||||
code <- filter (`elem` "+-.,><[]") <$> readFile fileName
|
||||
memory <- newMemory 30000
|
||||
parseAndInterpret memory code usage interpreterType
|
||||
_ -> exitWithMsg usage
|
||||
where
|
||||
parseAndInterpret memory code usage = \case
|
||||
"-s" -> interpret @StringInterpreter memory $ parse code
|
||||
"-a" -> interpret @ASTInterpreter memory $ parse code
|
||||
-- "-b" -> interpret @BytecodeInterpreter memory $ parse code
|
||||
-- "-o" -> interpret @OptimizingBytecodeInterpreter memory $ parse code
|
||||
t -> exitWithMsg $ "Invalid interpreter type: " <> t <> "\n" <> usage
|
||||
exitWithMsg msg = IO.hPutStrLn IO.stderr msg >> exitFailure
|
||||
Reference in New Issue
Block a user