module M0ld.Yeast where
import M0ld.AST
import M0ld.M0ld
import qualified M0ld.C
import qualified Data.Map as Map
wrap a b (f,c,p) = (f,a++c++b,p)

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 = "(SMOP__Object*[]) {" ++ (concat $ map (\r -> "SMOP_REFERENCE(interpreter," ++ reg r ++ "),") regs) ++ "NULL}"
        assign target expr = "if (" ++ reg target ++ ") SMOP_RELEASE(interpreter," ++ reg target ++ ");\n" ++ reg target ++ " = " ++ expr ++ ";\n"
        hint typ reg = Map.lookup (typ,reg) hints
        in
    case stmt of
    Call target identifier capture@(Capture invocant positional named) -> case hint RI invocant of
        Just (StringConstant "capture") -> case hint Constant identifier of
            Just (StringConstant "positional") -> case capture of
                (Capture invocant [i] []) -> emit $ assign target $ "SMOP__NATIVE__capture_positional(interpreter," ++ reg invocant ++ ",SMOP__NATIVE__int_fetch(" ++ reg i ++ "))"
            _ -> dispatch
        Just (StringConstant "interpreter") -> case hint Constant identifier of
            Just (StringConstant "goto") -> case capture of
                (Capture invocant [c] []) -> emit $ "frame->pc = " ++ (show $ i+1) ++ ";\n" ++ (assign target $ "smop_shortcut_interpreter_goto(interpreter," ++ reg invocant ++ ",SMOP_REFERENCE(interpreter," ++ reg c ++ "))") ++ "break;\n"
            _ -> dispatch
        Just (StringConstant "lexical scope") -> case hint Constant identifier of
            Just (StringConstant "exists") -> case capture of

                (Capture invocant [key] []) -> emit $ "frame->pc = " ++ (show $ i+1) ++ ";\n" ++ "frame->ret = &" ++ reg target ++ ";\n" ++ (assign target $ "smop_shortcut_lexical_scope_exists(interpreter," ++ reg invocant ++ ",SMOP_REFERENCE(interpreter," ++ reg key ++ "))") ++ "break;\n"
            _ -> dispatch
        _ -> dispatch
        where
        dispatch = emit $ 
            "frame->pc = " ++ (show $ i+1) ++ ";\n" ++
            "frame->ret = &" ++ reg target ++ ";\n" ++
            (assign target $ "SMOP_DISPATCH(\n" ++ (indent 2 $ "interpreter,\nSMOP_RI(" ++ reg invocant ++ "),\n" ++
                reg identifier ++ 
                ",\nSMOP__NATIVE__capture_create(interpreter," ++
                    list (invocant:positional) ++ ","
                    ++ list named ++
                ")\n" ) ++ ")") ++
            "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 (prefix,id) regMap labelsMap hints stmts = let 
    (i,cases) = foldl (emitStmt regMap labelsMap hints) (0,"") stmts
    name = prefix++(show id) in
    ("static void " ++ name ++ "(SMOP__Object* interpreter,SMOP__Yeast__Frame* frame) {\n" ++
    "  switch (frame->pc) {\n" ++
    indent 4 cases ++
    "case " ++ show i ++ ":" ++ "frame->pc = -1;\n" ++ 
    "  }\n" ++ 
    "}\n",name,(prefix,id+1))


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

compileToYeast prefix stmts =
    let labelsMap = mapLabelsToStmts stmts
        regMap    = mapRegisters stmts
        freeRegs  = countRegister stmts
        hints     = extractHints stmts
        (functions,constants,prefix') = dumpConstantsToC prefix stmts 
        (funcBody,funcName,prefix'') = emitFunc prefix' regMap labelsMap hints stmts
        in (funcBody:functions,"SMOP__Yeast_create(" ++ show freeRegs ++ "," ++ constants ++ ","
        ++ funcName ++ ")",prefix'')

dumpConstantsToC prefix stmts = 
    wrap "(SMOP__Object*[]) {" "NULL}" $ foldl dumpConstantToC ([],"",prefix) stmts

dumpConstantToC (f,c,p) (Decl reg (SubMold stmts)) = let 
    (f',c',p') = compileToYeast p stmts in
    (f++f',c++c'++",",p')

dumpConstantToC  (f,c,p) (Decl reg constant) = (f,c++M0ld.C.dumpConstantToC constant,p)

dumpConstantToC fcp _ = fcp 
