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"

data Environment = Environment { label :: Int
                               , 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 "=") = do
    liftIO $ truthOperator h "sete"
    return ()

handleSymbol h (ZorthASTWord ">") = do
    liftIO $ truthOperator h "setg"
    return ()

handleSymbol h (ZorthASTWord "<") = do
    liftIO $ truthOperator h "setl"
    return ()

handleSymbol h (ZorthASTWord ">=") = do
    liftIO $ truthOperator h "setge"
    return ()

handleSymbol h (ZorthASTWord "<=") = do
    liftIO $ truthOperator h "setle"
    return ()

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

handleSymbol _ (ZorthASTWordDecl (name,ast)) = do
    (Environment labels state) <- get
    put $ Environment labels (M.insert name ast state) -- maybe use `lens`?..
    return ()

-- honestly, this feels kinda janky, the way I manipulate state
handleSymbol h (ZorthASTIfElse (ifBranch,elseBranch)) = do
    (Environment l state) <- get
    let l1 = show $ l+1
    let l2 = show $ l+2
    put $ Environment (l+2) state
    liftIO $ hPutStr h $
             "    pop rax\n\
             \    cmp rax, 0\n\
             \    je .L"<>l1<>"\n"
    compileZorthASTState h ifBranch
    (Environment l' _) <- get
    put $ Environment l' state
    liftIO $ hPutStr h $ "    jmp .L"<>l2<>"\n.L"<>l1<>":\n"
    compileZorthASTState h elseBranch
    (Environment l'' _) <- get
    put $ Environment l'' state
    liftIO $ hPutStr h $ ".L"<>l2<>":\n"

truthOperator :: Handle -> String -> IO ()
truthOperator h s =
    hPutStr h $
    "    pop rbx\n\
    \    pop rax\n\
    \    cmp rax, rbx\n\
    \    "<>s<>" al\n\
    \    movsx rax, al\n\
    \    push rax\n"

compileZorthASTState :: Handle -> ZorthAST -> StateT Environment IO ()
compileZorthASTState h ast = (foldl (\m x -> m >> handleSymbol h x) (return ()) ast)

compileZorthAST :: Handle -> ZorthAST -> Environment -> IO ()
compileZorthAST h ast state = runStateT (compileZorthASTState h ast) state >> return ()

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