implementation module Sil.Compile

import StdList
import StdString

import Control.Applicative
import Control.Monad
import Control.Monad.RWST
import Control.Monad.Trans
import Data.Error
from Data.Func import $
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
from Text import <+

import qualified ABC.Assembler as ABC

import Sil.Syntax
import Sil.Util

instance toString CompileError
where
	toString (UndefinedName n) = "Undefined name '" <+ n <+ "'."
	toString VariableLabel     = "Variable stored at label."
	toString FunctionOnStack   = "Function stored on the stack."
	toString UnknownError      = "Unknown error."

compile :: Program -> MaybeError CompileError 'ABC'.Assembler
compile prog = case evalRWST start () zero of
	Error e  -> Error e
	Ok (_,p) -> Ok p
where
	start = mapM_ gen prog.p_funs

:: Address
	= LabelAddr String
	| StackAddr Int

:: CompileState =
	{ labels    :: ['ABC'.Label]
	, addresses :: 'M'.Map Name Address
	}

instance zero CompileState
where
	zero =
		{ labels    = ["_l" <+ i \\ i <- [0..]]
		, addresses = 'M'.newMap
		}

labels :: CompileState -> ['ABC'.Label]
labels cs = cs.labels

addresses :: CompileState -> 'M'.Map Name Address
addresses cs = cs.addresses

:: Gen a :== RWST () 'ABC'.Assembler CompileState (MaybeError CompileError) a

fresh :: Gen 'ABC'.Label
fresh = gets labels
	>>= \labs -> modify (\cs -> {cs & labels=tl labs})
	*> pure (hd labs)

reserveVar :: Int Name -> Gen Int
reserveVar i n = modify (\cs -> {cs & addresses='M'.put n (StackAddr i) cs.addresses}) *> pure (i+1)

class gen a :: a -> Gen ()

instance gen Function
where
	gen f = tell ['ABC'.Label f.f_name] *> gen f.f_code

instance gen CodeBlock
where
	gen cb = foldM reserveVar 0 [i.init_name \\ i <- cb.cb_init] *>
		mapM_ gen cb.cb_init *>
		mapM_ gen cb.cb_content

instance gen Initialisation
where
	gen init = comment ("Initialise " <+ init.init_name) *> tell ['ABC'.Create]

instance gen Statement
where
	gen st=:(Declaration n app) = gets addresses >>= \addrs -> case 'M'.get n addrs of
		Just (StackAddr i) -> comment (toString st) *> gen app *>
		                      tell ['ABC'.Update_a 0 $ i+1, 'ABC'.Pop_a 1]
		Just (LabelAddr _) -> liftT $ Error VariableLabel
		_                  -> liftT $ Error $ UndefinedName n
	gen (Application app)   = comment "Application" *> gen app
	gen (Return (Just app)) = comment "Return" *> gen app *> tell ['ABC'.Rtn]
	gen (Return Nothing)    = comment "Return" *> tell ['ABC'.Rtn]

instance gen Application
where
	gen (Name n) = gets addresses >>= \addrs -> case 'M'.get n addrs of
		Just (StackAddr i) -> tell ['ABC'.Push_a i]
		Just (LabelAddr _) -> liftT $ Error VariableLabel
		_                  -> liftT $ Error $ UndefinedName n
	gen (Literal (BLit b)) = tell ['ABC'.Create, 'ABC'.FillB b 0]
	gen (Literal (ILit i)) = tell ['ABC'.Create, 'ABC'.FillI i 0]
	gen (App n args) = gets addresses >>= \addrs -> case 'M'.get n addrs of
		Just (LabelAddr l) ->
			comment "Retrieve arguments" *> mapM gen args *>
			comment "Apply function" *> tell ['ABC'.Jsr l]
		Just (StackAddr _) -> liftT $ Error FunctionOnStack
		_                  -> liftT $ Error $ UndefinedName n

comment :: String -> Gen ()
comment s = tell ['ABC'.Comment s]