Simple Stack Machine Experimentation

main.hs

{-# LANGUAGE OverloadedStrings #-}

import Prelude hiding (Word)
import Data.Maybe

data Stack a = Stack [a] deriving
    (Show)

empty :: Stack a
empty = Stack []

push :: a -> Stack a -> Stack a
push x (Stack xs) = Stack (x:xs)

pop :: Stack a -> (Maybe a, Stack a)
pop (Stack []) = (Nothing, Stack [])
pop (Stack (x:xs)) = (Just x, Stack xs)

data Zipper a = Zip [a] [a]
    deriving (Show, Eq)

fromList :: [a] -> Zipper a
fromList = Zip []

toList :: Zipper a -> [a]
toList (Zip ls rs) = reverse ls ++ rs

cursor :: Zipper a -> a
cursor (Zip _ (a:_)) = a

safeCursor :: Zipper a -> Maybe a
safeCursor (Zip _ rs) = listToMaybe rs

left :: Zipper a -> Zipper a
left (Zip (a:ls) rs) = Zip ls (a:rs)
-- left = id

right :: Zipper a -> Zipper a
right (Zip ls (a:rs)) = Zip (a:ls) rs
-- right = id

insert :: a -> Zipper a -> Zipper aa
insert a (Zip ls rs) = Zip ls (a:rs)

type Word = Int
data Instruction = Push Word
                 | UnaryOp (Word -> Word)
                 | BinaryOp (Word -> Word -> Word)
                 | Duplicate
                 | Read
                 | Write
                 | Label Word
                 | JumpUp Word
                 | JumpDown Word
                 | SkipIfZero

type Program = [Instruction]
type Input = [Word]
type Output = Maybe Word

step :: (Program, Stack Word, Input) -> (Program, Stack Word, Input, Output)

step ((Push x:program'), stack, input) = (program', push x stack, input, Nothing)
step ((UnaryOp f:program'), stack, input) = (program', push (f a) stack', input, Nothing)
    where (Just a, stack') = pop stack
step ((BinaryOp f2:program'), stack, input) = (UnaryOp (f2 a):program', stack', input, Nothing)
    where (Just a, stack') = pop stack
step ((Read:program'), stack, (a:input')) = (program', push a stack, input', Nothing)
step ((Label _:program'), stack', input') = (program', stack', input', Nothing)
step ((SkipIfZero:next:program'), stack, input') = ((if a == 0 then id else (next:)) program', stack', input', Nothing)
    where (Just a, stack') = pop stack
step ((Duplicate:program'), stack, input') = (program', ((push a).(push a)) stack', input', Nothing)
    where (Just a, stack') = pop stack
step ((Write:program'), stack, input) = (program', stack', input, Just a)
    where (Just a, stack') = pop stack


run' :: Stack Word -> Program -> Input -> IO ()
run' stack [] input = return ()
run' stack program input = do
    let (program', stack', input', output') = step (program, stack, input)
    case output' of
        Just a -> print a
        Nothing -> return ()
    run' stack' program' input'

run :: Program -> IO ()
run program = run' empty program []

-- 2*3 + 1 + 4 = 11
main = run [ Label 0
           , Push 1
           , Push 2
           , Push 3
           , BinaryOp (*)
           , BinaryOp (+)
           , Push 4
           , BinaryOp (+)
           , Push 11
           , BinaryOp (-)
           , SkipIfZero
           , Write
           ]