dumping ground for compiler prototyping

typechecker.hs

-- This is a dumping ground for some ideas on how to implement compiler internals for wiz.
-- Right now does various transformations + checks on statements and expression trees.
-- It's mostly for me to prototype the type-checking and code-generation stuff.
-- I want to dig myself out of a corner with the language, and writing this in a high-level declarative way is kinda nice.
-- After I'm satisfied with how it roughly works, I want to port the implementation in C++
--
-- In particular, I wanted to know how to handle translating expression trees into
-- accumulated/in-place operations on registers, and forbidding any expressions with temporaries.
--
-- It turns out if an expression tree of left-associative operations branches only on the left side,
-- it can be represented as a series of in-place operations. Right-side branches are forbidden, because
-- the require the presence of a stack frame or static storage to hold on to the temporary data, and
-- wiz does not allocate any memory sections the user does not explicitly ask for, including expression temporaries.
--
-- ie. `a = (b + c) + d` is ok, but `a = b + (c + d)` is not.
--
-- `a = (b + c) + d` can be translated into:
--
-- ld a, b 
-- add a, c
-- add a, d

import Data.Word
import Data.Bits

data BinOp
    = BinOpSet
    | BinOpAdd
    | BinOpAddC
    | BinOpSub
    | BinOpSubC
    | BinOpMul
    | BinOpDiv
    | BinOpMod
    | BinOpBitwiseAnd
    | BinOpBitwiseOr
    | BinOpBitwiseXor
    deriving (Show, Eq)

data UnOp
    = UnOpMinus
    | UnOpBitwiseNot
    | UnOpIndirect
    deriving (Show, Eq)

data Type
    = TypeU8
    | TypeU16
    | TypeI8
    | TypeI16
    | TypePtr Type
    | TypeInteger
    deriving (Show, Eq)

data Sym
    = SymLet (Expr ())
    | SymReg Int Type
    | SymVar Int Type
    deriving (Show, Eq)

data Lit
    = LitInteger Integer
    | LitBool Bool
    deriving (Show, Eq)    

data Expr edata
    = ExprBin edata BinOp (Expr edata) (Expr edata)
    | ExprUn edata UnOp (Expr edata)
    | ExprLit edata Lit Type
    | ExprId edata String
    | ExprSym edata Sym
    deriving (Show, Eq)

data Stmt
    = StmtLet String (Expr ())
    | StmtVar String Int Type
    | StmtExpr (Expr ())
    | StmtBlock [Stmt]
    deriving (Show, Eq)

class Platform p where
    emitLoadInstr :: p -> Expr Type -> Expr Type -> Either String [Word8]
    emitUnInstr :: p -> Expr Type -> UnOp -> Expr Type -> Either String [Word8]
    emitBinInstr :: p -> Expr Type -> BinOp -> Expr Type -> Expr Type -> Either String [Word8]
    builtins :: p -> [(String, Sym)]

eitherConcatSequence :: [Either String [a]] -> Either String [a]
eitherConcatSequence x = either Left (Right . concat) $ sequence x

collectSymbols :: Stmt -> Either String [(String, Sym)]
collectSymbols stmt = case stmt of
    StmtLet name expr -> Right [(name, SymLet expr)]
    StmtVar name addr t ->
        if isLegalVarType t
            then Right [(name, SymVar addr t)]
            else Left $ "cannot declare variable of type " ++ (typeToString t)
    StmtExpr _ -> Right []
    StmtBlock subStmts -> eitherConcatSequence $ map collectSymbols subStmts

typeToString :: Type -> String
typeToString t = case t of
    TypeU8 -> "u8"
    TypeU16 -> "u16"
    TypeI8 -> "i8"
    TypeI16 -> "i16"
    TypePtr u -> "*" ++ (typeToString u) 
    TypeInteger -> "integer"

litDesc :: Lit -> String
litDesc v = case v of
    LitInteger _ -> "integer literal"
    LitBool _ -> "boolean literal"

removePtrType :: Type -> Either String Type
removePtrType t = case t of
    TypePtr u -> Right u
    _ -> Left $ "cannot indirect non-pointer type " ++ (typeToString t)

isSignedIntegralType :: Type -> Bool
isSignedIntegralType t = case t of
    TypeI8 -> True
    TypeI16 -> True
    TypeInteger -> True
    _ -> False

isIntegralType :: Type -> Bool
isIntegralType t = case t of
    TypeU8 -> True
    TypeU16 -> True
    TypeI8 -> True
    TypeI16 -> True
    TypeInteger -> True
    TypePtr _ -> False

isLegalVarType :: Type -> Bool
isLegalVarType t = case t of
    TypeU8 -> True
    TypeU16 -> True
    TypeI8 -> True
    TypeI16 -> True
    TypePtr _ -> True
    _ -> False

isUnsignedIntegralType :: Type -> Bool
isUnsignedIntegralType t = (isIntegralType t) && not (isSignedIntegralType t)

integralTypeRange :: Type -> Maybe (Integer, Integer)
integralTypeRange t = case t of
    TypeU8 -> Just (0, 255)
    TypeU16 -> Just (0, 65535)
    TypeI8 -> Just (-128, 127)
    TypeI16 -> Just (-32768, 32767)
    _ -> Nothing

exprData :: Expr edata -> edata
exprData e = case e of
    ExprBin d _ _ _ -> d
    ExprUn d _ _ -> d
    ExprLit d _ _ -> d
    ExprId d _ -> d
    ExprSym d _ -> d

unOpDesc :: UnOp -> String
unOpDesc op = case op of
    UnOpMinus -> "signed negation `-`"
    UnOpBitwiseNot -> "bitwise not `~`"
    UnOpIndirect -> "indirection `*`"

binOpDesc :: BinOp -> String
binOpDesc op = case op of
    BinOpSet -> "assignment `=`"
    BinOpAdd -> "addition `+`"
    BinOpAddC -> "addition-with-carry `+#`"
    BinOpSub -> "subtraction `-`"
    BinOpSubC -> "subtraction-with-carry `+#`"
    BinOpMul -> "multiplication `*`"
    BinOpDiv -> "division `/`"
    BinOpMod -> "modulo `%`"
    BinOpBitwiseAnd -> "bitwise and `&`"
    BinOpBitwiseOr -> "bitwise or `|`"
    BinOpBitwiseXor -> "bitwise xor `^`"

integerInRange :: Integer -> (Integer, Integer) -> Bool
integerInRange i (a, b) = a <= i && i <= b

checkTypedInteger :: Integer -> Type -> Either String Integer
checkTypedInteger i t =
    if isIntegralType t
        then case integralTypeRange t of
            Just (a, b)
                -> if integerInRange i (a, b)
                        then Right $ i
                        else Left $ "value " ++ (show i) ++ " is outside the range " ++ (show a) ++ " .. " ++ (show b)
            Nothing -> Right i
        else Left $ "type " ++ (typeToString t) ++ " is not integral so it cannot hold integers"

applyCheckedLitIntUnFn :: (Integer -> Either String Integer) -> Type -> Lit -> Either String Lit
applyCheckedLitIntUnFn f t v = case v of 
    LitInteger i | isIntegralType t
        -> case f i of
                Right r -> either Left (Right . LitInteger) (checkTypedInteger r t)
                Left err -> Left err
    _ -> Left "attempt to use unary integer function on non-integral value"

simplifyExprByLitUnFn :: (Lit -> Either String Lit) -> Type -> UnOp -> Expr Type -> Either String (Expr Type)
simplifyExprByLitUnFn f resultType op e = case e of 
    ExprLit _ v _ -> either Left (\x -> Right $ ExprLit resultType x resultType) (f v)
    _ -> Right $ ExprUn resultType op e

rightWrapUnFn :: (a -> b) -> (a -> Either String b)
rightWrapUnFn f = Right . f

failedUn :: UnOp -> Type -> Either String (Expr Type)
failedUn op t = Left $ "cannot apply " ++ (unOpDesc op) ++ " to type " ++ (typeToString t)

reducedUn :: UnOp -> Expr Type -> Either String (Expr Type)
reducedUn op e = 
    let t = exprData e
    in case op of
        UnOpMinus | isSignedIntegralType t -> simplifyExprByLitUnFn (applyCheckedLitIntUnFn (rightWrapUnFn negate) t) t op e
        UnOpBitwiseNot | isUnsignedIntegralType t
            -> case t of
                    TypeU8 -> simplifyExprByLitUnFn (applyCheckedLitIntUnFn (rightWrapUnFn (xor 0xFF)) t) t op e
                    TypeU16 -> simplifyExprByLitUnFn (applyCheckedLitIntUnFn (rightWrapUnFn (xor 0xFFFF)) t) t op e
                    _ -> failedUn op t
        UnOpIndirect
            -> case removePtrType t of
                    Right u -> Right $ ExprUn u op e
                    Left err -> Left err
        _ -> failedUn op t


applyCheckedLitBinIntFn :: (Integer -> Integer -> Either String Integer) -> Type -> Lit -> Lit -> Either String Lit
applyCheckedLitBinIntFn f t v1 v2 = case (v1, v2) of
    (LitInteger i1, LitInteger i2) | isIntegralType t
        -> case f i1 i2 of
                Right r -> either Left (Right . LitInteger) (checkTypedInteger r t)
                Left err -> Left err
    _ -> Left "attempt to use binary integer function on non-integral value"

simplifyExprByLitBinFn :: (Lit -> Lit -> Either String Lit) -> Type -> BinOp -> Expr Type -> Expr Type -> Either String (Expr Type)
simplifyExprByLitBinFn f resultType op e1 e2 = case (e1, e2) of 
    (ExprLit _ v1 _, ExprLit _ v2 _) -> either Left (\x -> Right $ ExprLit resultType x resultType) (f v1 v2)
    _ -> Right $ ExprBin resultType op e1 e2

makeCompatibleExprs :: Expr Type -> Expr Type -> Maybe (Expr Type, Expr Type)
makeCompatibleExprs e1 e2 =
    let t1 = exprData e1
        t2 = exprData e2
    in case (e1, e2) of
        _ | exprData e1 == exprData e2
            -> Just (e1, e2)
        (_, ExprLit TypeInteger (LitInteger v2) _) | isIntegralType t1
            -> case integralTypeRange t1 of
                    Just (a, b) | integerInRange v2 (a, b)
                        -> Just (e1, ExprLit t1 (LitInteger v2) t1)
                    _ -> Nothing            
        (ExprLit TypeInteger (LitInteger v1) _, _) | isIntegralType t2
            -> case integralTypeRange t2 of
                    Just (a, b) | integerInRange v1 (a, b)
                        -> Just (ExprLit t2 (LitInteger v1) t2, e2)
                    _ -> Nothing
        _ -> Nothing

failedBin :: BinOp -> Expr Type -> Expr Type -> Either String (Expr Type)
failedBin op e1 e2 = Left $ "cannot apply " ++ (binOpDesc op) ++ " between types " ++ (typeToString (exprData e1)) ++ " and " ++ (typeToString (exprData e2))

rightWrapBinFn :: (a -> b -> c) -> (a -> b -> Either String c)
rightWrapBinFn f = (\x y -> Right $ f x y)

checkedDiv :: Integer -> Integer -> Either String Integer
checkedDiv x y = case y of
    0 -> Left "division by zero encountered"
    _ -> Right $ div x y

checkedMod :: Integer -> Integer -> Either String Integer
checkedMod x y = case y of
    0 -> Left "modulo by zero encountered"
    _ -> Right $ mod x y

reducedArithBin :: BinOp -> Expr Type -> Expr Type -> (Integer -> Integer -> Either String Integer) -> Either String (Expr Type)
reducedArithBin op e1 e2 f = case makeCompatibleExprs e1 e2 of
    Just (e1_, e2_) ->
        let t2 = exprData e2_
        in simplifyExprByLitBinFn (applyCheckedLitBinIntFn f t2) t2 op e1_ e2_
    Nothing -> failedBin op e1 e2

reducedRuntimeBin :: BinOp -> Expr Type -> Expr Type -> Either String (Expr Type)
reducedRuntimeBin op e1 e2 = case makeCompatibleExprs e1 e2 of
    Just (e1_, e2_) -> Right $ ExprBin (exprData e2_) op e1_ e2_
    Nothing -> failedBin op e1 e2

reducedBin :: BinOp -> Expr Type -> Expr Type -> Either String (Expr Type)
reducedBin op e1 e2 = case op of
    BinOpSet -> reducedRuntimeBin op e1 e2
    BinOpAdd -> reducedArithBin op e1 e2 (rightWrapBinFn (+))
    BinOpAddC -> reducedRuntimeBin op e1 e2
    BinOpSub -> reducedArithBin op e1 e2 (rightWrapBinFn (-))
    BinOpSubC -> reducedRuntimeBin op e1 e2
    BinOpMul -> reducedArithBin op e1 e2 (rightWrapBinFn (*))
    BinOpDiv -> reducedArithBin op e1 e2 (checkedDiv)
    BinOpMod -> reducedArithBin op e1 e2 (checkedMod)
    BinOpBitwiseAnd -> reducedArithBin op e1 e2 (rightWrapBinFn (.&.))
    BinOpBitwiseOr -> reducedArithBin op e1 e2 (rightWrapBinFn (.|.))
    BinOpBitwiseXor -> reducedArithBin op e1 e2 (rightWrapBinFn xor)

reducedSym :: [(String, Sym)] -> Sym -> Either String (Expr Type)
reducedSym syms sym = case sym of
    SymLet expr -> reducedExpr syms expr
    SymReg _ t -> Right $ ExprSym t sym
    SymVar _ t -> Right $ ExprSym t sym

reducedExpr :: [(String, Sym)] -> Expr edata -> Either String (Expr Type)
reducedExpr syms e = case e of
    ExprBin _ op left right
        -> case (reducedExpr syms left, reducedExpr syms right) of
                (Right typedLeft, Right typedRight) -> reducedBin op typedLeft typedRight
                (Left err, _) -> Left err
                (_, Left err) -> Left err
    ExprUn _ op term
        -> case reducedExpr syms term of
                Right typedTerm -> reducedUn op typedTerm
                Left err -> Left err
    ExprLit _ v t -> case v of
        LitInteger i -> case checkTypedInteger i t of 
            Right _ -> Right $ ExprLit t (LitInteger i) t
            Left err -> Left err
        _ -> Left $ "could not create " ++ (litDesc v) ++ " of type " ++ (typeToString t)
    ExprId _ name
        -> case lookup name syms of
                Just sym -> reducedSym syms sym
                Nothing -> Left $ "could not resolve symbol " ++ name
    ExprSym _ sym -> reducedSym syms sym

isLeafExpr :: Expr edata -> Bool
isLeafExpr e = case e of
    ExprBin _ _ _ _ -> False
    ExprUn _ _ _ -> False
    ExprLit _ _ _ -> True
    ExprId _ _ -> True
    ExprSym _ _ -> True

failedRightSideRequiresTemp :: BinOp -> Either String a
failedRightSideRequiresTemp op = Left $ "right side of " ++ (binOpDesc op) ++ " requires a temporary"

emitAssignmentExpr :: (Platform a) => a -> Expr Type -> Expr Type -> Either String [Word8]
emitAssignmentExpr p dest src = case src of
    ExprBin _ BinOpSet left right
        -> eitherConcatSequence
                [ emitAssignmentExpr p left right
                , emitLoadInstr p dest left ]
    ExprBin _ op left right | left /= dest && right == dest -> failedRightSideRequiresTemp op 
    ExprBin _ op left right
        | isLeafExpr left && isLeafExpr right
            -> case emitBinInstr p dest op left right of
                Left _ -> eitherConcatSequence
                                [ emitLoadInstr p dest left
                                , emitBinInstr p dest op dest right ]
                Right code -> Right code
    ExprBin _ op left right
        | not (isLeafExpr left) && isLeafExpr right
            -> emitBinInstr p dest op dest right
    ExprBin _ op _ _ -> failedRightSideRequiresTemp op
    ExprUn _ op term
        -> case emitUnInstr p dest op term of
                Left _ -> eitherConcatSequence
                                [ emitLoadInstr p dest term
                                , emitUnInstr p dest op dest]
                Right code -> Right code
    ExprLit _ _ _ -> emitLoadInstr p dest src
    ExprId _ _ -> Left "internal error: identifier should have been translated into symbol"
    ExprSym _ _ -> emitLoadInstr p dest src

emitExprStmt :: (Platform a) => a -> Either String (Expr Type) -> Either String [Word8]
emitExprStmt p expr = case expr of
    Right (ExprBin _ BinOpSet left right) -> emitAssignmentExpr p left right
    Left err -> Left err
    _ -> Left "expression cannot be used as a statement"

emitStmt :: (Platform a) => a -> [(String, Sym)] -> Stmt -> Either String [Word8]
emitStmt p syms stmt = case stmt of
    StmtLet _ _ -> Right []
    StmtVar _ _ _ -> Right []
    StmtExpr e -> emitExprStmt p $ reducedExpr syms e
    StmtBlock subStmts -> eitherConcatSequence $ map (emitStmt p syms) subStmts

compileStmt :: (Platform a) => a -> Stmt -> Either String [Word8]
compileStmt p stmt = case collectSymbols stmt of 
    Right syms -> emitStmt p (syms ++ (builtins p)) stmt
    Left err -> Left err

data Platform6502 = Platform6502

data Reg6502
    = Reg6502_A
    | Reg6502_X
    | Reg6502_Y
    | Reg6502_S
    deriving (Show, Eq, Enum)

data Arg6502
    = Arg6502_Reg Reg6502
    | Arg6502_ImmediateU8 Word8
    | Arg6502_ZeroPage Word8    
    | Arg6502_ZeroPageIndexedByX Word8
    | Arg6502_ZeroPageIndexedByY Word8
    | Arg6502_Direct Word16
    | Arg6502_DirectX Word16
    | Arg6502_DirectY Word16    
    | Arg6502_Indirect Word16
    | Arg6502_ZeroPageIndexedByXIndirect Word8
    | Arg6502_ZeroPageIndirectIndexedByY Word8
    | Arg6502_Error

instance Platform Platform6502 where
    emitLoadInstr _ dest src = case (toArg6502 dest, toArg6502 src) of
        (Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n) -> Right [0xA9, n]
        (Arg6502_Reg Reg6502_X, Arg6502_ImmediateU8 n) -> Right [0xA2, n]
        (Arg6502_Reg Reg6502_Y, Arg6502_ImmediateU8 n) -> Right [0xA0, n]
        (Arg6502_Reg Reg6502_A, Arg6502_Reg Reg6502_X) -> Right [0x8A]
        (Arg6502_Reg Reg6502_A, Arg6502_Reg Reg6502_Y) -> Right [0x98]
        (Arg6502_Reg Reg6502_X, Arg6502_Reg Reg6502_A) -> Right [0xAA]
        (Arg6502_Reg Reg6502_Y, Arg6502_Reg Reg6502_A) -> Right [0xA8]
        (Arg6502_Reg Reg6502_X, Arg6502_Reg Reg6502_S) -> Right [0xBA]
        (Arg6502_Reg Reg6502_S, Arg6502_Reg Reg6502_X) -> Right [0x9A]
        -- TODO: more instructions
        _ -> Left "could not find matching load instruction"

    emitUnInstr _ dest op term = case (toArg6502 dest, op, toArg6502 term) of
        (Arg6502_Reg Reg6502_A, UnOpMinus, Arg6502_Reg Reg6502_A)
            -> Right [0x49, 0xFF, 0x18, 0x69, 0x01]
        (Arg6502_Reg Reg6502_A, UnOpBitwiseNot, Arg6502_Reg Reg6502_A)
            -> Right [0x49, 0xFF]
        -- TODO: more instructions
        _ -> Left $ "could not find matching unary instruction for " ++ (unOpDesc op)

    emitBinInstr _ dest op left right = case (toArg6502 dest, op, toArg6502 left, toArg6502 right) of
        (Arg6502_Reg Reg6502_A, BinOpAdd, Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n)
            -> Right [0x18, 0x69, n]
        (Arg6502_Reg Reg6502_A, BinOpAddC, Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n)
            -> Right [0x69, n]
        (Arg6502_Reg Reg6502_A, BinOpSub, Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n)
            -> Right [0x38, 0xE9, n]
        (Arg6502_Reg Reg6502_A, BinOpSubC, Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n)
            -> Right [0x38, 0xE9, n]
        (Arg6502_Reg Reg6502_A, BinOpBitwiseAnd, Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n)
            -> Right [0x29, n]
        (Arg6502_Reg Reg6502_A, BinOpBitwiseOr, Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n)
            -> Right [0x09, n]
        (Arg6502_Reg Reg6502_A, BinOpBitwiseXor, Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n)
            -> Right [0x49, n]
        -- TODO: more instructions
        _ -> Left $ "could not find matching binary instruction for " ++ (binOpDesc op)

    builtins _ = map (\(name, reg, t) -> (name, SymReg (fromEnum reg) t))
                [ ("a", Reg6502_A, TypeU8)
                , ("x", Reg6502_X, TypeU8)
                , ("y", Reg6502_Y, TypeU8)]

toArg6502 :: Expr Type -> Arg6502
toArg6502 e = case e of
    ExprSym TypeU8 (SymReg reg _) -> Arg6502_Reg (toEnum reg :: Reg6502)
    ExprLit TypeU8 (LitInteger n) _ -> Arg6502_ImmediateU8 $ fromIntegral n
    _ -> Arg6502_Error

data PlatformGBZ80 = PlatformGBZ80

data RegGBZ80
    = RegGBZ80_A
    | RegGBZ80_B
    | RegGBZ80_C
    | RegGBZ80_D
    | RegGBZ80_E
    | RegGBZ80_H
    | RegGBZ80_L
    | RegGBZ80_AF
    | RegGBZ80_BC
    | RegGBZ80_DE
    | RegGBZ80_HL
    | RegGBZ80_SP
    deriving (Show, Eq, Enum)

data ArgGBZ80
    = ArgGBZ80_Reg RegGBZ80
    | ArgGBZ80_ImmediateU8 Word8
    | ArgGBZ80_ImmediateU16 Word16
    | ArgGBZ80_Direct Word16
    | ArgGBZ80_IndirectBC
    | ArgGBZ80_IndirectDE    
    | ArgGBZ80_IndirectHL
    | ArgGBZ80_HighPage Word8
    | ArgGBZ80_HighPageIndexedByC Word8
    | ArgGBZ80_Error

instance Platform PlatformGBZ80 where
    emitLoadInstr _ dest src = case (toArgGBZ80 dest, toArgGBZ80 src) of
        (ArgGBZ80_Reg RegGBZ80_B, ArgGBZ80_ImmediateU8 n) -> Right [0x06, n]
        (ArgGBZ80_Reg RegGBZ80_C, ArgGBZ80_ImmediateU8 n) -> Right [0x0E, n]
        (ArgGBZ80_Reg RegGBZ80_D, ArgGBZ80_ImmediateU8 n) -> Right [0x16, n]
        (ArgGBZ80_Reg RegGBZ80_E, ArgGBZ80_ImmediateU8 n) -> Right [0x1E, n]
        (ArgGBZ80_Reg RegGBZ80_H, ArgGBZ80_ImmediateU8 n) -> Right [0x26, n]
        (ArgGBZ80_Reg RegGBZ80_L, ArgGBZ80_ImmediateU8 n) -> Right [0x2E, n]
        (ArgGBZ80_IndirectHL, ArgGBZ80_ImmediateU8 n) -> Right [0x36, n]
        (ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_ImmediateU8 n) -> Right [0x3E, n]
        -- TODO: more instructions
        _ -> Left "could not find matching load instruction"

    emitUnInstr _ dest op term = case (toArgGBZ80 dest, op, toArgGBZ80 term) of
        -- TODO: more instructions
        _ -> Left $ "could not find matching unary instruction for " ++ (unOpDesc op)

    emitBinInstr _ dest op left right = case (toArgGBZ80 dest, op, toArgGBZ80 left, toArgGBZ80 right) of
        (ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_ImmediateU8 n)
            -> Right [0xC6, n]
        (ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_Reg RegGBZ80_B)
            -> Right [0x80]
        (ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_Reg RegGBZ80_C)
            -> Right [0x81]
        (ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_Reg RegGBZ80_D)
            -> Right [0x82]            
        (ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_Reg RegGBZ80_E)
            -> Right [0x83]            
        (ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_Reg RegGBZ80_H)
            -> Right [0x84]        
        (ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_Reg RegGBZ80_L)
            -> Right [0x85]
        (ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_Reg RegGBZ80_A)
            -> Right [0x87]
        (ArgGBZ80_Reg RegGBZ80_A, BinOpAddC, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_ImmediateU8 n)
            -> Right [0xCE, n]
        (ArgGBZ80_Reg RegGBZ80_A, BinOpSub, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_ImmediateU8 n)
            -> Right [0xD6, n]
        (ArgGBZ80_Reg RegGBZ80_A, BinOpSubC, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_ImmediateU8 n)
            -> Right [0xDE, n]
        -- TODO: more instructions
        _ -> Left $ "could not find matching binary instruction for " ++ (binOpDesc op)

    builtins _ = map (\(name, reg, t) -> (name, SymReg (fromEnum reg) t))
                [ ("a", RegGBZ80_A, TypeU8)
                , ("b", RegGBZ80_B, TypeU8)
                , ("c", RegGBZ80_C, TypeU8)
                , ("d", RegGBZ80_D, TypeU8)
                , ("e", RegGBZ80_E, TypeU8)
                , ("h", RegGBZ80_H, TypeU8)
                , ("l", RegGBZ80_L, TypeU8)
                , ("af", RegGBZ80_AF, TypeU16)
                , ("bc", RegGBZ80_BC, TypeU16)
                , ("de", RegGBZ80_DE, TypeU16)
                , ("hl", RegGBZ80_HL, TypeU16)
                , ("sp", RegGBZ80_SP, TypeU16)]

toArgGBZ80 :: Expr Type -> ArgGBZ80
toArgGBZ80 e = case e of
    ExprSym TypeU8 (SymReg reg _) -> ArgGBZ80_Reg (toEnum reg :: RegGBZ80)
    ExprLit TypeU8 (LitInteger n) _ -> ArgGBZ80_ImmediateU8 $ fromIntegral n
    _ -> ArgGBZ80_Error 

main :: IO ()
main = do
    -- TODO: real unit tests / assertions
    -- reduced expression tree is a single literal
    print $ reducedExpr
                [("whoa", SymLet (ExprLit () (LitInteger 4) TypeInteger))]
                (ExprBin () BinOpMul
                    (ExprId () "whoa")
                    (ExprLit () (LitInteger 3) TypeInteger))

    -- runtime variables cannot be reduced further (maybe link-time)
    print $ reducedExpr
                [("ok", SymVar 123 TypeInteger)]
                (ExprId () "ok")

    -- let expression is reduced when referenced later
    print $ reducedExpr
                [("cats", SymLet (ExprBin () BinOpAdd
                                    (ExprLit () (LitInteger 12) TypeInteger)
                                    (ExprLit () (LitInteger 1) TypeInteger)))]
                (ExprId () "cats")

    -- test reducing constant subtrees of a runtime expression
    print $ reducedExpr
                [ ("a", SymReg 1 TypeU8)
                , ("cats", SymLet (ExprBin () BinOpAdd 
                                    (ExprLit () (LitInteger 12) TypeInteger)
                                    (ExprLit () (LitInteger 1) TypeInteger)))]
                (ExprBin () BinOpSet
                    (ExprId () "a")
                    (ExprBin () BinOpAdd
                        (ExprLit () (LitInteger 5) TypeU8)
                        (ExprId () "cats")))

    -- test reducing constant subtree of runtime subtree of runtime expression
    print $ reducedExpr
                [ ("a", SymReg 1 TypeU8)
                , ("egg", SymLet (ExprLit () (LitInteger 57) TypeInteger))]
                (ExprBin () BinOpSet
                    (ExprId () "a")
                    (ExprBin () BinOpAddC
                        (ExprId () "a")
                        (ExprBin () BinOpMul
                            (ExprId () "egg")
                            (ExprLit () (LitInteger 2) TypeInteger))))

    -- unary operation on runtime term cannot be reduced
    print $ reducedExpr
                [ ("a", SymReg 1 TypeU8)
                , ("x", SymReg 2 TypeU8)]
                (ExprBin () BinOpSet
                    (ExprId () "a")
                    (ExprUn () UnOpBitwiseNot
                        (ExprId () "x")))

    -- quick check leaf expr function works as described
    print $ isLeafExpr $ ExprSym () (SymReg 1 TypeU8)

    -- `a = 5 + cats; a = a +# egg * 2; a = ~x;`
    -- load constant, addc constant, load x, xor $FF``
    let testBlock = StmtBlock
            [ StmtLet "cats" (ExprBin () BinOpAdd
                                (ExprLit () (LitInteger 12) TypeInteger)
                                (ExprLit () (LitInteger 1) TypeInteger))
            , StmtLet "egg" (ExprLit () (LitInteger 57) TypeU8)
            , StmtExpr $ ExprBin () BinOpSet
                (ExprId () "a")
                (ExprBin () BinOpAdd
                    (ExprLit () (LitInteger 5) TypeU8)
                    (ExprId () "cats"))
            , StmtExpr $ ExprBin () BinOpSet
                (ExprId () "a")
                (ExprBin () BinOpAddC
                    (ExprId () "a")
                    (ExprBin () BinOpMul
                        (ExprId () "egg")
                        (ExprLit () (LitInteger 2) TypeInteger)))
            , StmtExpr $ ExprBin () BinOpSet
                (ExprId () "a")
                (ExprUn () UnOpBitwiseNot
                    (ExprId () "x"))]

    print $ collectSymbols $ testBlock    
    print $ compileStmt Platform6502 $ testBlock

    -- `a + 5` is not a valid statement
    print $ compileStmt Platform6502 $ 
        StmtExpr (ExprBin () BinOpAdd 
            (ExprId () "a")
            (ExprLit () (LitInteger 5) TypeU8))

    -- `a = 5 + a` - not possible without temporary
    print $ compileStmt PlatformGBZ80 $
        StmtExpr (ExprBin () BinOpSet
            (ExprId () "a")
            (ExprBin () BinOpAdd
                (ExprLit () (LitInteger 5) TypeU8)
                (ExprId () "a")))

    -- `a = a + a` - single add instruction
    print $ compileStmt PlatformGBZ80 $
        StmtExpr (ExprBin () BinOpSet
            (ExprId () "a")
            (ExprBin () BinOpAdd 
                (ExprId () "a")
                (ExprId () "a")))

    -- `a = 123; a = a + b` load instr and add instr
    print $ compileStmt PlatformGBZ80 $
        StmtBlock
            [ StmtExpr $ ExprBin () BinOpSet
                (ExprId () "a")
                (ExprLit () (LitInteger 123) TypeInteger)
            , StmtExpr $ ExprBin () BinOpSet
                (ExprId () "a")
                (ExprBin () BinOpAdd
                    (ExprId () "a")
                    (ExprId () "b"))]

    -- Check that constrainted integers are bounds-checked.
    print $ reducedExpr [] $ ExprLit () (LitInteger 1000) TypeU8
    print $ reducedExpr [] $ ExprLit () (LitInteger 1000) TypeU16
    print $ reducedExpr [] $ ExprLit () (LitInteger 70000) TypeU16
    print $ reducedExpr [] $ ExprLit () (LitInteger $ -128) TypeU8
    print $ reducedExpr [] $ ExprLit () (LitInteger $ -128) TypeI8
    print $ reducedExpr [] $ ExprLit () (LitInteger $ -129) TypeI8
    print $ reducedExpr [] $ ExprLit () (LitInteger $ -129) TypeI16
    print $ reducedExpr [] $ ExprLit () (LitInteger 70000) TypeInteger

    -- Output:
    -- 
    -- Right (ExprLit TypeInteger (LitInteger 12) TypeInteger)
    -- Right (ExprSym TypeInteger (SymVar 123 TypeInteger))
    -- Right (ExprLit TypeInteger (LitInteger 13) TypeInteger)
    -- Right (ExprBin TypeU8 BinOpSet (ExprSym TypeU8 (SymReg 1 TypeU8)) (ExprLit TypeU8 (LitInteger 18) TypeU8))
    -- Right (ExprBin TypeU8 BinOpSet (ExprSym TypeU8 (SymReg 1 TypeU8)) (ExprBin TypeU8 BinOpAddC (ExprSym TypeU8 (SymReg 1 TypeU8)) (ExprLit TypeU8 (LitInteger 114) TypeU8)))
    -- Right (ExprBin TypeU8 BinOpSet (ExprSym TypeU8 (SymReg 1 TypeU8)) (ExprUn TypeU8 UnOpBitwiseNot (ExprSym TypeU8 (SymReg 2 TypeU8))))
    -- True
    -- Right [("cats",SymLet (ExprBin () BinOpAdd (ExprLit () (LitInteger 12) TypeInteger) (ExprLit () (LitInteger 1) TypeInteger))),("egg",SymLet (ExprLit () (LitInteger 57) TypeU8))]
    -- Right [169,18,105,114,138,73,255]
    -- Left "expression cannot be used as a statement"
    -- Left "right side of addition `+` requires a temporary"
    -- Right [135]
    -- Right [62,123,128]
    -- Left "value 1000 is outside the range 0 .. 255"
    -- Right (ExprLit TypeU16 (LitInteger 1000) TypeU16)
    -- Left "value 70000 is outside the range 0 .. 65535"
    -- Left "value -128 is outside the range 0 .. 255"
    -- Right (ExprLit TypeI8 (LitInteger (-128)) TypeI8)
    -- Left "value -129 is outside the range -128 .. 127"
    -- Right (ExprLit TypeI16 (LitInteger (-129)) TypeI16)
    -- Right (ExprLit TypeInteger (LitInteger 70000) TypeInteger)
    --
    --
    -- TODO: I wonder if there should be a way to qualify operators as forced runtime operators.
    -- (eg. for addition, to force carry to be generated) `a = a !+ b` or something
    --
    -- TODO: label statements (eg. for goto, etc)
    -- TODO: link-time expressions, such as expressions involving addresses of code section labels.
    -- still constant (so should be folded into a single term) but aren't knowable until after first instruction selection pass.
    -- Type and constness information should be enough to determine the instructions generated without knowing actual value.
    -- Assume it's a constant address that is not in zero page / high page, since labels of variables are known before instruction selection even starts
    -- Keep link-time expression in tree form, but know its reduced operand type - resolve at last possible moment
    --
    -- TODO: pointer arithmetic
    -- TODO: pointer views of registers (so we can indirect them and read a byte value)
    -- TODO: signed views of registers (so we can do signed comparsion, multiplication, etc)
    --
    -- TODO: type-checked version of expressions like `lda (ptr, x)` (indexed-by-x indirect) in 6502 instruction set.
    -- This is complicated! ptr is a 16-bit address, but x is a byte offset from ptr, so unaligned accesses are possible.
    --
    -- C prevents unaligned reads on a T* by multiplying index and/or pointer arithmetic terms by sizeof(T), but we can't do that without temporary / hidden calculations
    --
    -- Wiz is against most hidden computations because it is as much as possible directly targetting machine instructions, so we need some way to
    -- recognize unaligned pointer arithmetic and generate a single instruction
    --
    -- An unaligned access would look something like this I think?
    -- a = *((ptr as u16 + x as u16) as *u8)