module Micro.Asm.Sdcc where

import qualified Micro.Ast as A
import Text.Parsec (SourcePos, sourceColumn, sourceLine)

toIdent :: A.Ident -> String
toIdent id = "_" ++ id

toLabel :: A.Ident -> Bool -> String
toLabel id False = toIdent id ++ "::"
toLabel id True = toIdent id ++ ":"

toData :: A.Type -> String
toData (A.Type t)
  | t == "bool" || t == "u8" || t == "s8" = ".ds 1"
  | t == "u16" || t == "s16" = ".ds 2"
  | otherwise = ".ds 2"
toData (A.FuncType _ _) = ".ds 2"

toInit :: A.Type -> A.Expr -> String
toInit (A.Type t) (A.Num v _)
  | t == "bool" || t == "u8" || t == "s8" = ".db " ++ show v
  | t == "u16" || t == "s16" = ".dw " ++ show v
  | otherwise = ".dw " ++ show v
toInit _ v = ".dw " ++ show v

posToIdent :: SourcePos -> String
posToIdent p = "l" ++ show (sourceLine p) ++ "$" ++ show (sourceColumn p)

header :: String -> [String]
header version = [";", "; File created by Micro v" ++ version ++ " (SDCC)", ";"]

module' :: String -> String
module' name = "\t.module " ++ name

optsdcc :: String
optsdcc = "\t.optsdcc -mz80"

area :: String -> String
area name = "\n\t.area " ++ name

globl :: String -> String
globl id = "\t.globl " ++ id

mul8 :: A.Expr -> A.Expr -> SourcePos -> [String]
mul8 a b p = do
  let loop = posToIdent p
  let loop0 = loop ++ "z"
  oCode (emit a)
    ++ [ "\tor a",
         "\tjr z, " ++ toIdent loop0,
         "\tld b, a",
         "\tdec b",
         "\tjr z, " ++ toIdent loop0
       ]
    ++ oCode (emit b)
    ++ [ "\tld c, a",
         toLabel loop True,
         "\tadd c",
         "\tdjnz "
           ++ toIdent loop,
         toLabel loop0 True
       ]

data Output = Output
  { oPre :: [String],
    oInit :: [String],
    oData :: [String],
    oCode :: [String]
  }

emit :: A.Expr -> Output
emit x =
  case x of
    (A.Module name _) -> o {oPre = [module' name, optsdcc, ""]}
    (A.Var id typ val priv False _) ->
      o
        { oPre = [globl $ toIdent id | not priv],
          oData = [toLabel id priv, "\t" ++ toData typ],
          oInit = ["__init" ++ toLabel id True, "\t" ++ toInit typ val]
        }
    (A.Num v _) -> o {oCode = ["\tld a, #" ++ show v]}
    (A.Variable id _) -> o {oCode = ["\tld a, (" ++ toIdent id ++ ")"]}
    -- cases where constant folding didn't happen
    (A.BinOp A.Plus _ (A.Num a _) (A.Num b _)) -> o {oCode = [show a ++ "+" ++ show b]}
    (A.BinOp A.Minus _ (A.Num a _) (A.Num b _)) -> o {oCode = [show a ++ "-" ++ show b]}
    (A.BinOp A.Mul _ (A.Num a _) (A.Num b _)) -> o {oCode = [show a ++ "*" ++ show b]}
    (A.BinOp A.Div _ (A.Num a _) (A.Num b _)) -> o {oCode = [show a ++ "/" ++ show b]}
    (A.BinOp A.Plus _ a (A.Num 1 _)) ->
      o {oCode = oCode (emit a) ++ ["\tinc a"]}
    (A.BinOp A.Plus _ a (A.Num v _)) ->
      o {oCode = oCode (emit a) ++ ["\tadd #" ++ show v]}
    (A.BinOp A.Plus _ a b) ->
      o {oCode = oCode (emit a) ++ ["\tld c, a"] ++ oCode (emit b) ++ ["\tadd c"]}
    (A.BinOp A.Minus _ a (A.Num 1 _)) ->
      o {oCode = oCode (emit a) ++ ["\tdec a"]}
    (A.BinOp A.Minus _ a (A.Num v _)) ->
      o {oCode = oCode (emit a) ++ ["\tsub #" ++ show v]}
    (A.BinOp A.Minus _ a b) ->
      o {oCode = oCode (emit a) ++ ["\tld c, a"] ++ oCode (emit b) ++ ["\tld b, a", "\tld a, c", "\tsub b"]}
    (A.BinOp A.Mul _ _ (A.Num 0 _)) ->
      o {oCode = ["\txor a"]}
    (A.BinOp A.Mul _ _ (A.Num 1 _)) -> o
    (A.BinOp A.Mul _ a (A.Num 2 _)) ->
      o {oCode = oCode (emit a) ++ ["\tsla a"]}
    (A.BinOp A.Mul _ a (A.Num v _)) ->
      o {oCode = oCode (emit a) ++ ["\tld c, a"] ++ replicate (fromInteger v - 1) "\tadd c"}
    (A.BinOp A.Mul p a b) -> do
      o {oCode = mul8 a b p}
    (A.BinOp A.Assign _ (A.Variable id _) b) ->
      o {oCode = oCode (emit b) ++ ["\tld (" ++ toIdent id ++ "), a"]}
    _ -> o {oCode = [";; unimplemented " ++ show x]}
  where
    o = Output [] [] [] []

generate :: String -> [A.Expr] -> String
generate version ast = do
  let out = map emit ast
  let pre = concatMap oPre out
  let dat = [area "_DATA", area "_INITIALIZED"] ++ concatMap oData out
  let code = [area "_CODE"] ++ concatMap oCode out ++ ["hlt0:", "\tjr hlt0"]
  let init = [area "_INITIALIZER"] ++ concatMap oInit out ++ [area "_GSINIT", area "_GSFINAL"]
  unlines $ header version ++ pre ++ dat ++ code ++ init