Simple and Hacky Stack Machine in Haskell

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

reset :: Zipper a -> Zipper a
reset = fromList . toList

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 a
insert a (Zip ls rs) = Zip ls (a:rs)


data Unary = Add1
           | Sub1
    deriving (Show, Eq)

op :: Unary -> Word -> Word
op Add1 = (+1)
op Sub1 = (+(-1))

data Binary = Add
            | Sub
            | Mul
     deriving (Show, Eq)

op2 :: Binary -> Word -> Word -> Word
op2 Add = (+)
op2 Sub = (-)
op2 Mul = (*)


type Word = Int
data Instruction = Push Word
                 | UnaryOp Unary
                 | BinaryOp Binary
                 | Duplicate
                 | Drop
                 | Read
                 | Write
                 | Label Word
                 | Jump Word
                 | SkipIfZero
                 | NoOp
    deriving (Show, Eq)

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


jumpTo :: Program -> Word -> Program
jumpTo program = jumpTo' $ reset program
    where jumpTo' program@(Zip ls (Label w:rs)) labelName
              | w == labelName = program
              | otherwise = jumpTo' (right program) labelName
          jumpTo' program labelName = jumpTo' (right program) labelName

step :: (Program, Stack Word, Input) -> (Program, Stack Word, Input, Output)
step (program@(Zip ls (Push x:rs)), stack, input) = (right program, push x stack, input, Nothing)
step (program@(Zip ls (UnaryOp unary:rs)), stack, input) = (right program, push (op unary a) stack', input, Nothing)
    where (Just a, stack') = pop stack
step (program@(Zip ls (BinaryOp binary:rs)), stack, input) = (right program, push (op2 binary a b) stack'', input, Nothing)
    where (Just a, stack') = pop stack
          (Just b, stack'') = pop stack'
step (program@(Zip ls (Read:rs)), stack, (a:input')) = (right program, push a stack, input', Nothing)
step (program@(Zip ls (Label _:rs)), stack', input') = (right program, stack', input', Nothing)
step (program@(Zip ls (SkipIfZero:next:rs)), stack, input') = (right . (if a == 0 then right else id) $ program, stack', input', Nothing)
    where (Just a, stack') = pop stack
step (program@(Zip ls (Duplicate:rs)), stack, input') = (right program, ((push a).(push a)) stack', input', Nothing)
    where (Just a, stack') = pop stack
step (program@(Zip ls (Drop:rs)), stack, input') = (right program, stack', input', Nothing)
    where (Just a, stack') = pop stack
step (program@(Zip ls (Write:rs)), stack, input') = (right program, stack', input', Just a)
    where (Just a, stack') = pop stack
step (program@(Zip _ (Jump a:_)), stack', input') = (jumpTo program a, stack', input', Nothing)
step (program@(Zip _ (NoOp:_)), stack', input') = (right program, stack', input', Nothing)
step _ = error "Operation Not Implemented Yet"


run :: [Instruction] -> Input -> IO ()
run program input = mapM_ print $ output program input

output :: [Instruction] -> Input -> [Word]
output program input = catMaybes $ output_ (fromList program) empty input
    where output_ (Zip _ []) _ _ = []
          output_ program stack input = output' : output_ program' stack' input'
            where (program', stack', input', output') = step (program, stack, input)
          

program =  [ Push 10
           , Label 0
           , UnaryOp Sub1
           , Duplicate
           , Write
           , Duplicate
           , SkipIfZero
           , Jump 0
           ]

main = run program [1..]