module Compiler where

import Parser
import Text.Printf (printf)
import Control.Monad (void) 
import System.Process
import System.IO
import Control.Monad.Trans.State
import Control.Monad.IO.Class (liftIO)
import qualified Data.Map as M

forthPrelude :: Handle -> IO () 
forthPrelude h = do
    hPutStr h
             "global _start\n\
             \print_number:\n\
             \    push rbp\n\
             \    mov rbp, rsp\n\
             \    sub rsp, 128 \n\
             \    mov rdx, -1 \n\
             \    jmp l2\n\
             \    add rsp, 28\n\
             \    pop rbp\n\
             \    ret\n\
             \l1:\n\
             \    dec  rdx\n\
             \    imul rax, rbx, 1717986919\n\
             \    shr  rax, 34\n\
             \    imul rcx, rax, 10\n\
             \    sub  rbx, rcx\n\
             \    add  rbx, '0'\n\
             \    mov  qword[rbp+8*rdx], rbx\n\
             \\n\
             \    mov rbx, rax\n\
             \l2:\n\
             \    cmp rbx, 0\n\
             \    jne l1\n\
             \    mov qword[rbp-8], `\\n` \n\
             \    mov rax, 1\n\
             \    mov rdi, 1\n\
             \    lea rsi, [rbp+8*rdx]\n\
             \    neg rdx\n\
             \    imul rdx, 8\n\
             \    syscall\n\
             \    leave\n\
             \    ret\n\
             \_start:\n"

type Environment = M.Map String ZorthAST

handleSymbol :: Handle -> ZorthExpr -> StateT Environment IO ()

handleSymbol h (ZorthASTInteger i) = 
    do
        liftIO $ hPutStrLn h $ "    push "<>show i
        return ()

handleSymbol h (ZorthASTWord "+") = do
    liftIO $ hPutStr h 
             "    pop rbx\n\
             \    pop rax\n\
             \    add rax, rbx\n\
             \    push rax\n"
    return ()

handleSymbol h (ZorthASTWord "-") = do
    liftIO $ hPutStr h 
             "    pop rbx\n\
             \    pop rax\n\
             \    sub rax, rbx\n\
             \    push rax\n"
    return ()

handleSymbol h  (ZorthASTWord "ret") = do
    liftIO $ hPutStr h 
             "    mov rax,60\n\
             \    mov rdi,0\n\
             \    syscall\n"
    return ()

handleSymbol h (ZorthASTWord "dup") = do
    liftIO $ hPutStr h 
             "    pop rax\n\
             \    push rax\n\
             \    push rax\n"
    return ()

handleSymbol h (ZorthASTWord "swap") = do
    liftIO $ hPutStr h 
             "    pop rax\n\
             \    pop rbx\n\
             \    push rax\n\
             \    push rbx\n"
    return ()

handleSymbol h (ZorthASTWord "drop") = do
    liftIO $ hPutStr h "    add rsp, 8\n"
    return ()

handleSymbol h (ZorthASTWord ".") = do
    liftIO $ hPutStr h 
              "    pop rbx\n\
              \    call print_number\n"
    return ()

handleSymbol h (ZorthASTWord w) = do
    state <- get
    liftIO $ compileZorthAST h (state M.! w) state -- parent env to child and discard
    return ()

handleSymbol _ (ZorthASTWordDecl (name,ast)) = do
    state <- get
    put $ M.insert name ast state
    return ()

compileZorthAST :: Handle -> ZorthAST -> Environment -> IO ()
compileZorthAST h ast state = runStateT (foldl (\m x -> m >> handleSymbol h x) (return ()) ast) state >> return ()

compileZorth :: Handle -> ZorthAST -> IO ()
compileZorth _ [] = return ()
compileZorth h xs = do
    forthPrelude h
    compileZorthAST h xs M.empty