monadic stack to register machine translator

[William Lee Irwin III]

module GT where
import Monad
import Monoid
import MonadState
import MonadWriter
import MonadRWS

-- Just a quick exercise in using monads.
-- Thought it'd be nice to share with the class.

data GOp
	= PushVal Integer
	| Push Integer
	| Pop Integer
	| Slide Integer
	| Update Integer
	| GAdd | GSub | GMul | GDiv | GMod | GPow
	| GNeg | GAbs
	deriving (Eq, Ord, Read, Show)

type Tmp = Integer

data ROp
	= LoadImm Tmp Integer
	| RAdd Tmp Tmp Tmp
	| RSub Tmp Tmp Tmp
	| RMul Tmp Tmp Tmp
	| RDiv Tmp Tmp Tmp
	| RMod Tmp Tmp Tmp
	| RPow Tmp Tmp Tmp
	| RNeg Tmp Tmp
	| RAbs Tmp Tmp
	deriving (Eq, Ord, Read, Show)

type CounterT m t = StateT Integer m t
type StackT t = State [Integer] t

type GST t = RWS () [ROp] (Integer, [Integer]) t

class Stack f where
	pushVal, push, pop, update, slide :: Integral t => t -> f ()
	popVal :: Integral t => f t

instance Integral t => Stack (RWS () [ROp] (t, [t])) where
	pushVal n = do
					(ctr, stk) <- get
					put (ctr, fromIntegral n : stk)
	popVal = do
					(ctr, top:stk) <- get
					put (ctr, stk)
					return (fromIntegral top)
	push n = do
				(ctr, stk) <- get
				put (ctr, stk!!fromIntegral n : stk)
	pop n = do
				(ctr, stk) <- get
				put (ctr, drop (fromIntegral n) stk)
	slide n = do
				(ctr, top:stk) <- get
				put (ctr, top : drop (fromIntegral n) stk)
	update n = do
				(ctr, top:stk) <- get
				let (front, _:back) = splitAt (fromIntegral n) stk
				put (ctr, front ++ [top] ++ back)

class Counter f where
	gen :: Enum t => f t

instance Integral t => Counter (RWS () [ROp] (t, [t])) where
	gen = do
				(ctr, stk) <- get
				put (ctr + 1, stk)
				return . toEnum . fromIntegral $ ctr + 1

instance (Enum t, Monad m) => Counter (StateT t m) where
	gen = do
				ctr <- get
				put $ succ ctr
				ctr <- get
				return . toEnum $ fromEnum ctr
				
translate gOps = snd $ evalRWS (mapM trans gOps) () (0,[])

trans :: GOp -> GST ()
trans i = case i of
	PushVal n	->
		do
			reg <- gen
			tell [LoadImm reg n]
			pushVal reg
	Push n		-> push n
	Pop n		-> pop n
	Slide n		-> slide n
	Update n	-> update n
	GAdd		-> doBinOp RAdd
	GSub		-> doBinOp RSub
	GMul		-> doBinOp RMul
	GDiv		-> doBinOp RDiv
	GMod		-> doBinOp RMod
	GPow		-> doBinOp RPow
	GNeg		-> doUnOp RNeg
	GAbs		-> doUnOp RAbs
	where
		doUnOp op =
			do
				x <- popVal
				y <- gen
				tell [op y x]
				pushVal y
		doBinOp op =
			do
				x <- popVal
				y <- popVal
				z <- gen
				tell [op z x y]
				pushVal z