content: module M0ld.JS where
  import M0ld.AST
  import M0ld.M0ld
  import Data.List (intersperse)
  import qualified M0ld.C
  import qualified Data.Map as Map
  
  indent depth code = unlines $ map indentLine $ lines code where
      indentLine "" = ""
      indentLine line = (take depth $ repeat ' ') ++ line
  
  emitStmt regs labels hints (i,c) stmt =
      let emit code = (i+1,c ++ "case "++ (show i) ++ ":\n" ++ indent 2 code)
          reg r = "frame.reg[" ++ (show $ resolveReg r regs) ++ "]" 
          list regs = "[" ++ (concat $ intersperse "," $ map reg regs) ++ "]"
          assign target expr = reg target ++ " = " ++ expr ++ ";\n"
          hint typ reg = Map.lookup (typ,reg) hints
          in
      case stmt of
      -- we can insert special variants here
      Call target identifier capture@(Capture invocant positional named) -> dispatch
          where 
          t = show $ resolveReg target regs
          dispatch = emit $ "frame.pc = " ++ (show $ i+1) ++ ";\n" ++
              "frame.ret = " ++ t ++ ";\n" ++
              "var tmp = " ++
              (reg invocant ++ ".DISPATCH(interpreter," ++ reg identifier ++ ",new P6capture(" ++ 
              list (invocant:positional) ++ "," ++  list named ++ "));") ++ "if (tmp != undefined) frame.reg["++t++"] = tmp;else "++"break;\n"
  
      --Call2 target responder identifier capture ->
      --    map (\r -> resolveReg r regs) [target,responder,identifier,capture]
  
      Goto label -> emit $ "frame.pc = "++(show $ resolveLabelDef label labels) ++ ";\n" ++ "break;\n";
  
      Br value iftrue iffalse ->
          emit $ "frame.pc = " ++
          reg value
           ++
          " == SMOP__NATIVE__bool_false ? " ++
          (show $ resolveLabelDef iffalse labels) ++
          " : " ++
          (show $ resolveLabelDef iftrue labels) ++
          ";\n" ++
          "break;\n"
  
      LabelDef label -> (i,c)
  
      Decl reg value -> (i,c)
      
      Hint _ _ _ -> (i,c)
  
      Assign lvalue rvalue -> emit $ reg lvalue ++ " = " ++ reg rvalue ++ ";\n"
  
  emitFunc regMap labelsMap hints stmts = let 
      (i,cases) = foldl (emitStmt regMap labelsMap hints) (0,"") stmts
      in
      "function(interpreter,frame) {\n" ++
      "  switch (frame.pc) {\n" ++
      indent 4 cases ++
      "case " ++ show i ++ ":" ++ "frame.pc = -1;\n" ++ 
      "  }\n" ++ 
      "}\n"
  
  
  stmtSize (Decl _ _) = 0
  stmtSize (LabelDef _) = 0
  stmtSize (Hint _ _ _) = 0
  stmtSize _ = 1
  
  mapLabelsToStmts :: [Stmt] -> LabelsMap
  mapLabelsToStmts stmts = fst $ foldl addLabelDef (Map.empty,0) stmts
      where
          addLabelDef (labels,offset) (LabelDef label) = (Map.insert label offset labels,offset)
          addLabelDef (labels,offset) stmt = (labels,offset+stmtSize stmt)
  
  extractHints = foldl addHint Map.empty
      where
          addHint hints (Hint typ reg ri) = Map.insert (typ,reg) ri hints
          addHint hints _ = hints
  
  compileToJS stmts =
      let labelsMap = mapLabelsToStmts stmts
          regMap    = mapRegisters stmts
          freeRegs  = countRegister stmts
          hints     = extractHints stmts
          constants = dumpConstantsToJS stmts 
          in "new P6Mold(" ++ show freeRegs ++ "," ++ constants ++ "," ++ (emitFunc regMap labelsMap hints stmts) ++ ")"
  
  dumpConstantsToJS stmts = "[" ++ (concat $ intersperse "," $ concat [dumpConstantToJS c | Decl reg c <- stmts]) ++ "]"
  
  dumpConstantToJS value = case value of
      StringConstant str -> ["\"" ++ str ++ "\""]
      IntegerConstant int -> [show int]
      None -> []
      Var name -> [name]
      SubMold stmts -> [compileToJS stmts]
  