module SwfCompiler where
-- arch-tag: Scheme to Swf Compiler
-- (add-hook 'haskell-mode-hook 'turn-on-haskell-ghci)

import SchemeAS
import SwfAssembly
import SchemeParser
import PPrint
import List (find)
import Text.ParserCombinators.Parsec

primOps = [ ("+", 2, ActionAdd)
	  , ("-", 2, ActionSubtract)
	  , ("/", 2, ActionDivide)
	  , ("*", 2, ActionMultiply)
	  , ("eq", 2, ActionEquals)
	  , ("<", 2, ActionLess)
	  ]

prim op = find (\(op2,_,_) -> (op == op2)) primOps


eta_expand primop nargs = [ActionDefineFunction var_names (load_vars ++ [primop, ActionReturn])]
    where var_names = [ x | x <- (map ((++) "a" . show) [0..(nargs - 1)])]
	  load_vars = concatMap (\name -> [ActionPushString name, ActionGetVariable]) (reverse var_names)

compile_expr label_prefix expr =
    case expr of
	      Const (StringLit s) -> [ActionPushString s]
	      Const (IntLit i) -> [ActionPushFloat (fromInteger i)]
	      Identifier i ->
		  {- if the identifier is a primative assembly operator, then do eta expansion on it,
		     otherwise just load the value from the location bound to the identifier 
		     -}
		  case prim i of 
			 Just (_,2,op) -> eta_expand op 2
			 Nothing -> [ActionPushString i , ActionGetVariable]
	      Lambda (FixedFormals f) body -> [ActionDefineFunction f ((compile_expr label_prefix body) ++ [ActionReturn])]
	      Lambda (VarFormals v) body -> [ActionDefineFunction [v] ((compile_expr label_prefix body) ++ [ActionReturn])]
	      Lambda (FixedVarFormals f v) body -> [ActionDefineFunction (f ++ [v]) ((compile_expr label_prefix body) ++ [ActionReturn])]
	      Apply e0 el -> (concatMap (uncurry compile_expr) $ zip [label_prefix ++ "." ++ show i | i <- [2..]] el) ++
	      {- test if we are applying a primative assembly operation, eg (+ 2 3), or
		 calling a function, eg (myfun 2 3)
		 -}
			     case primE e0 of
			          Just (_,_,op) -> [op]
				  Nothing -> [ActionPushFloat (fromIntegral (length el))] ++
					     (compile_expr (label_prefix ++ ".1") e0) ++
					     [ActionPushString "", ActionCallMethod]
	      If e0 e1 e2 -> compile_expr (label_prefix ++ ".1") e0 ++
			     [ActionIf (label_prefix ++ ".iftrue")] ++
			     compile_expr (label_prefix ++ ".2") e2 ++
			     [ActionJump (label_prefix ++ ".ifdone"), Label (label_prefix ++ ".iftrue")] ++
			     compile_expr (label_prefix ++ ".3") e1 ++
			     [Label (label_prefix ++ ".ifdone")]
	      Set i e -> [ActionPushString i] ++
			 compile_expr label_prefix e ++
			 [ActionSetVariable]

			  
	where
	primE (Identifier i) = prim i
	primE _ = Nothing


-- main

predefined =
    [ ActionDefineFunction ["str"] 
      [ ActionPushString "str" 
      , ActionGetVariable
      , ActionTrace
      ]
    , ActionPushString "display"
    , ActionSetVariable
    ]


compile :: [Expr] -> [SwfAssembly]
compile exprs = concatMap (uncurry compile_expr) $ zip [show i | i <- [1..]] exprs

doCompile :: [Char] -> [SwfAssembly]
doCompile s = case parse exprs "testAsmSwf" s of 
             Left err -> error ("Failed to compile: " ++ s)
	     Right exprs -> compile exprs

testCompiler s = case parse exprs "testAsm" s of 
	          Left err -> print err
	          Right x -> print (Movie "display.swf" [(Frame 0 (compile x))])