Principles of Programming Languages homework

doublestack.hs

import Control.Monad.State  -- to use get and put


main :: IO ()
main = do
    print $ test $ DoubleStack [1,2,3] [4,5,6]
    print $ test $ DoubleStack [] [4,5,6]
    where
        -- the test function
        test :: DoubleStack Integer -> Maybe Integer
        test = evalState $ do
            push 7
            move
            move
            pop
            pop


-- 2 list or an invalid stack
data DoubleStack a = DoubleStack [a] [a] | InvalidStack


-- pop a value from the second stack
pop :: State (DoubleStack a) (Maybe a)
pop = do
    stack <- get
    let (new_stack, out) = pop' stack
    put new_stack
    return out
    where
        -- returns the (new-stack, popped-value) tuple
        pop' :: DoubleStack a -> (DoubleStack a, Maybe a)
        pop' (DoubleStack xs (y:ys)) = (DoubleStack xs ys, Just y)
        pop' (DoubleStack _  [])     = (InvalidStack, Nothing)
        pop' InvalidStack            = (InvalidStack, Nothing)


-- push a value on the first stack
push :: a -> State (DoubleStack a) ()
push value = do
    stack <- get
    put (push' value stack)
    return ()
    where
        -- returns the updated stack, or Invalid
        push' :: a -> DoubleStack a -> DoubleStack a
        push' x (DoubleStack xs ys) = DoubleStack (x:xs) ys
        push' x InvalidStack        = InvalidStack


-- move a value from the first stack to the second one
move :: State (DoubleStack a) ()
move = do
    stack <- get
    put $ move' stack
    return ()
    where
        -- returns the updated stack, or Invalid
        move' :: DoubleStack a -> DoubleStack a
        move' (DoubleStack (x:xs) ys) = DoubleStack xs (x:ys)
        move' (DoubleStack [] _)      = InvalidStack
        move' InvalidStack            = InvalidStack