maggicl/drbrainfuck.hs
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Refactored flow with State monad

Browse source
This commit is contained in:
Claudio Maggioni (maggicl) 2020-11-05 22:22:41 +01:00
parent 5f8a2cadf3
commit 60cfc648ea
3 changed files with 69 additions and 76 deletions

5
drbrainfuck.cabal
View file

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 9fbea002e6987c6029337af23e79a7d02807f8a29debc342b0336a02d9242ae5
-- hash: 16cbb08fa613499e2eb7c2ee55f9989d2a3895d105af6c712db09e00b2ac56c3
name: drbrainfuck
version: 0.1.0.0
@ -35,6 +35,7 @@ library
src
build-depends:
base >=4.7 && <5
, transformers
default-language: Haskell2010
executable drbrainfuck-exe
@ -47,6 +48,7 @@ executable drbrainfuck-exe
build-depends:
base >=4.7 && <5
, drbrainfuck
, transformers
default-language: Haskell2010
test-suite drbrainfuck-test
@ -60,4 +62,5 @@ test-suite drbrainfuck-test
build-depends:
base >=4.7 && <5
, drbrainfuck
, transformers
default-language: Haskell2010

1
package.yaml
View file

@ -21,6 +21,7 @@ description: Please see the README on GitHub at <https://github.com/gith
dependencies:
- base >= 4.7 && < 5
- transformers
library:
source-dirs: src

139
src/Interpreter.hs
View file

@ -1,9 +1,9 @@
-- vim: set ts=4 sw=4 et tw=80:
module Interpreter where
-- vim: set ts=4 sw=4 et tw=80:
import Data.Maybe (catMaybes)
import Control.Monad (liftM, ap)
import Debug.Trace
import Control.Monad.Trans.State
data Instruction = TapeLeft | TapeRight | Add | Sub | Out | In | LoopStart | LoopEnd
deriving (Eq, Show)
@ -32,25 +32,8 @@ updateCell Sub (Byte i) = Byte (i - 1)
type Tape = [Byte]
type Program = [Instruction]
data State = State {
tape :: Tape,
dp :: Int,
program :: Program,
ip :: Int } deriving (Show)
data Execution a = Working a | Crash Error | Done deriving (Show)
instance Monad Execution where
(Crash e) >>= _ = Crash e
Done >>= _ = Done
(Working d) >>= f = f d
instance Functor Execution where
fmap = liftM
instance Applicative Execution where
pure = return
(<*>) = ap
data Memory = Memory { tape :: Tape, dp :: Int, ip :: Int } deriving (Show)
data Term = Working | Crash Error | Done deriving (Show)
toProgram :: String -> Program
toProgram s = catMaybes $ fmap parseInstr s
@ -65,29 +48,32 @@ errorDesc :: Error -> String
errorDesc NegTape = "ERROR: '<' not working. Cannot access negative tape positions."
errorDesc LoopNoMatch = "ERROR: '[' or ']' not working. Matching parenthesis not found."
incrIP :: State -> State
incrIP :: Memory -> Memory
incrIP p = p { ip = ip p + 1 }
execUpdate :: Instruction -> State -> State
execUpdate i p = p { tape = newTape }
where newTape = tapeHelp (tape p) (dp p) (updateCell i)
execUpdate :: Instruction -> State Memory Term
execUpdate i = state stateF
where stateF p = (Working, p { tape = newTape p })
newTape p = tapeHelp (tape p) (dp p) (updateCell i)
execTapeLeft :: State -> Execution State
execTapeLeft p = case dp p of 0 -> Crash NegTape
n -> Working p { dp = n - 1 }
execTapeLeft :: State Memory Term
execTapeLeft = state $ \p -> case dp p of 0 -> (Crash NegTape, p)
n -> (Working, p { dp = n - 1 })
execTapeRight :: State -> State
execTapeRight p = p { tape = tape p ++ newTape, dp = dp p + 1 }
where newTape = case dp p == length (tape p) - 1 of True -> [Byte 0]
_ -> []
execTapeRight :: State Memory Term
execTapeRight = state $ \p -> (Working, newMem p)
where newMem p = p { tape = tape p ++ newTape p, dp = dp p + 1 }
newTape p = case dp p == length (tape p) - 1 of True -> [Byte 0]
_ -> []
execIn :: State -> IO (Execution State)
execIn p = do chr <- getChar
tp <- pure $ fromEnum chr
return $ Working p { tape = tapeHelp (tape p) (dp p) (\_ -> Byte tp) }
execIn :: StateT Memory IO Term
execIn = StateT $ \p -> do chr <- getChar
tp <- pure $ fromEnum chr
return (Working, newTape tp p)
where newTape tp p = p { tape = tapeHelp (tape p) (dp p) (\_ -> Byte tp) }
execOut :: State -> IO (Execution State)
execOut p = putChar (chr (tape p !! dp p)) >> (return . Working $ p)
execOut :: StateT Memory IO Term
execOut = StateT $ \p -> putChar (chr (tape p !! dp p)) >> (return (Working, p))
findMatching :: Program -> Instruction -> Int -> Maybe Int
findMatching prg par = fmHelper $ -1
@ -104,49 +90,52 @@ findMatching prg par = fmHelper $ -1
| otherwise = fmHelper acc $ next s
where c = prg !! s
execLoop :: Instruction -> State -> Execution State
execLoop d w = case posOrF of Just n -> Working w { ip = n }
Nothing -> Crash LoopNoMatch
where isZero = (tape w !! dp w) == Byte 0
execLoop :: Program -> Instruction -> State Memory Term
execLoop p d = state $ \w -> case posOrF w of Just n -> (Working, w { ip = n })
Nothing -> (Crash LoopNoMatch, w)
where isZero w = (tape w !! dp w) == Byte 0
jump = case d of LoopStart -> isZero
LoopEnd -> not isZero
posOrF = case jump of True -> findMatching (program w) d (ip w)
_ -> Just $ ip w
LoopEnd -> not . isZero
posOrF w = case jump w of True -> findMatching p d (ip w)
_ -> Just $ ip w
execute :: State -> IO (Execution State)
execute w = runInstr w >>= andThen
where instrFor :: State -> State -> IO (Execution State)
instrFor w = case (program w !! ip w) of
TapeLeft -> return . execTapeLeft
TapeRight -> return . Working . execTapeRight
Add -> return . Working . (execUpdate Add)
Sub -> return . Working . (execUpdate Sub)
execute :: Program -> Memory -> IO (Term, Memory)
execute p = runStateT runInstruction
where runInstruction :: StateT Memory IO Term
runInstruction = do i <- runInstr
d <- checkDone i
loopBack d
where loopBack s = case s of Working -> runInstruction
t -> return t
runInstr :: StateT Memory IO Term
runInstr = StateT $ \m -> (runStateT (instrFor m) m)
instrFor :: Memory -> StateT Memory IO Term
instrFor w = case traceShowId $ (p !! ip w) of
TapeLeft -> toStateT execTapeLeft
TapeRight -> toStateT execTapeRight
Add -> toStateT $ execUpdate Add
Sub -> toStateT $ execUpdate Sub
In -> execIn
Out -> execOut
l -> return . execLoop l
l -> toStateT $ execLoop p l
andThen :: Execution State -> IO (Execution State)
andThen s = case s >>= checkDone of
Working s -> execute s
t -> return t
toStateT :: (Monad m) => State s a -> StateT s m a
toStateT x = StateT $ (\s -> return . runState x $ s)
runInstr :: State -> IO (Execution State)
runInstr w = instrFor w $ w
checkDone :: State -> Execution State
checkDone ps
| (length . program) ps == newIP = Done
| otherwise = Working $ ps { ip = newIP }
where newIP = ip ps + 1
checkDone :: Term -> StateT Memory IO Term
checkDone Working = StateT $ return . isDone
where isDone ps
| length p == newIP = (Done, ps)
| otherwise = traceShowId (Working, ps { ip = newIP })
where newIP = ip ps + 1
checkDone t = return t
initState :: Program -> State
initState p = State {
tape = [Byte 0],
dp = 0,
program = p,
ip = 0}
initMemory :: Memory
initMemory = Memory { tape = [Byte 0], dp = 0, ip = 0 }
run :: String -> IO (Execution State)
run s = case catMaybes . fmap parseInstr $ s of [] -> return Done
l -> execute . initState $ l
run :: String -> IO ((Term, Memory))
run p = case catMaybes . fmap parseInstr $ p of [] -> return (Done, initMemory)
pp -> execute pp initMemory