civicaml/stringify.ml

open Types

let tab = "    "

(* string -> string *)
let indent = Str.global_replace (Str.regexp "^\\(.\\)") (tab ^ "\\1")

(* const -> string *)
let const2str = function
    | BoolVal  b -> string_of_bool b
    | IntVal   i -> string_of_int i
    | FloatVal f ->
        (* Add a trailing zero to a float stringification *)
        (match string_of_float f with
        | s when s.[String.length s - 1] = '.' -> s ^ "0"
        | s -> s
        )

(* Copied from util.ml to avoid circular dependency *)
let nameof = function
    | GlobalDec (_, name, _)
    | GlobalDef (_, _, name, _, _)
    | FunDec (_, name, _, _)
    | FunDef (_, _, name, _, _, _)
    | VarDec (_, name, _, _)
    | Param (_, name, _)
    | Dim (name, _) -> name
    | _ -> raise InvalidNode

(* operator -> string *)
let op2str = function
    | Neg -> "-"
    | Not -> "!"
    | Add -> "+"
    | Sub -> "-"
    | Mul -> "*"
    | Div -> "/"
    | Mod -> "%"
    | Eq  -> "=="
    | Ne  -> "!="
    | Lt  -> "<"
    | Le  -> "<="
    | Gt  -> ">"
    | Ge  -> ">="
    | And -> "&&"
    | Or  -> "||"

(* ctype -> string *)
let rec type2str = function
    | Void  -> "void"
    | Bool  -> "bool"
    | Int   -> "int"
    | Float -> "float"
    | Array (t, dims)       -> (type2str t) ^ "[" ^ (concat ", " dims) ^ "]"
    | ArrayDepth (t, ndims) -> (type2str t) ^ "[" ^ string_of_int ndims ^ "]"
    | FlatArray t           -> (type2str t) ^ "[]"

and concat sep nodes = String.concat sep (List.map node2str nodes)

(* node -> string *)
and node2str node =
    let str = node2str in
    match node with

    (* Global *)
    | Program (decls, _) ->
        concat "\n\n" decls
    | Param (param_type, name, _) ->
        (type2str param_type) ^ " " ^ name
    | FunDec (ret_type, name, params, _) ->
        let params = concat ", " params in
        "extern " ^ type2str ret_type ^ " " ^ name ^ "(" ^ params ^ ");"
    | FunDef (export, ret_type, name, params, body, _) ->
        let export = if export then "export " else "" in
        let params = "(" ^ (concat ", " params) ^ ")" in
        export ^ type2str ret_type ^ " " ^ name ^ params ^ " " ^ str body
    | GlobalDec (var_type, name, _) ->
        "extern " ^ type2str var_type ^ " " ^ name ^ ";"
    | GlobalDef (export, ret_type, name, init, _) ->
        let export = if export then "export " else "" in
        let init = match init with
            | Some value -> " = " ^ str value
            | None -> ""
        in
        export ^ (type2str ret_type) ^ " " ^ name ^ init ^ ";"

    (* Statements *)
    | VarDec (var_type, name, None, _) ->
        (type2str var_type) ^ " " ^ name ^ ";"
    | VarDec (var_type, name, Some init, _) ->
        (type2str var_type) ^ " " ^ name ^ " = " ^ (str init) ^ ";"
    | Assign (name, None, value, _) ->
        name ^ " = " ^ (str value) ^ ";"
    | Assign (name, Some dims, value, _) ->
        name ^ "[" ^ (concat ", " dims) ^ "] = " ^ (str value) ^ ";"
    | Expr expr ->
        str expr ^ ";"
    | Return (value, _) ->
        "return " ^ (str value) ^ ";"
    | If (cond, body, _) ->
        "if (" ^ str cond ^ ") " ^ str body
    | IfElse (cond, true_body, false_body, _) ->
        "if (" ^ str cond ^ ") " ^ str true_body ^ " else " ^ str false_body
    | While (cond, body, _) ->
        "while (" ^ str cond ^ ") " ^ str body
    | DoWhile (cond, body, _) ->
        "do " ^ str body ^ " while (" ^ str cond ^ ");"
    | For (counter, start, stop, step, body, _) ->
        let step = match step with
            | Const (IntVal 1, _) -> ""
            | value -> ", " ^ str value
        in
        let range = str start ^ ", " ^ str stop ^ step in
        "for (int " ^ counter ^ " = " ^ range ^ ") " ^ str body
    | Allocate (name, dims, _, _) ->
        name ^ " := <allocate>(" ^ concat ", " dims ^ ");"
    | Block body ->
        let rec append = function
            | [] -> ""
            | [last] -> last
            | "" :: tl -> append tl
            | hd :: tl -> hd ^ "\n" ^ append tl
        in
        "{\n" ^ indent (append (List.map str body)) ^ "\n}"

    (* Expressions *)
    | Const (c, _) -> const2str c
    | ArrayConst (dims, _) -> "[" ^ concat ", " dims ^ "]"
    | Var (v, None, _) -> v
    | Var (name, Some dims, _) -> name ^ (str (ArrayConst (dims, [])))
    | Monop (op, opnd, _) -> op2str op ^ str opnd
    | Binop (op, left, right, _) ->
        "(" ^ str left ^ " " ^ op2str op ^ " " ^ str right ^ ")"
    | TypeCast (ctype, value, _) -> "(" ^ type2str ctype ^ ")" ^ str value
    | FunCall (name, args, _) -> name ^ "(" ^ (concat ", " args) ^ ")"
    | Cond (cond, t, f, _) -> "(" ^ (str cond) ^ " ? " ^ str t ^ " : " ^ str f ^ ")"

    (* Annotation nodes print more information at higher verbosity, for
     * debugging purposes *)
    | VarLet (dec, dims, value, _) when args.verbose >= verbosity_debug ->
        "<let:" ^ node2str (Assign (nameof dec, dims, value, [])) ^ ">"
    | VarUse (dec, dims, _)        when args.verbose >= verbosity_debug ->
        "<use:" ^ node2str (Var (nameof dec, dims, [])) ^ ">"
    | FunUse (dec, params, _)      when args.verbose >= verbosity_debug ->
        "<use:" ^ node2str (FunCall (nameof dec, params, [])) ^ ">"
    | Dim (name, _)                when args.verbose >= verbosity_debug ->
        "<dim:" ^ name ^ ">"
    | ArrayScalar value            when args.verbose >= verbosity_debug ->
        "<scalar:" ^ str value ^ ">"
    | Arg node                     when args.verbose >= verbosity_debug ->
        "<arg:" ^ str node ^ ">"

    | VarLet (dec, dims, value, _) ->
        node2str (Assign (nameof dec, dims, value, []))
    | VarUse (dec, dims, _) ->
        node2str (Var (nameof dec, dims, []))
    | FunUse (dec, args, _) ->
        node2str (FunCall (nameof dec, args, []))
    | Dim (name, _) -> name
    | ArrayScalar node
    | ArrayInit (node, _)
    | Arg node -> str node

    | VarDecs nodes
    | LocalFuns nodes -> concat "\n" nodes

    | DummyNode -> "<dummy>"

(* ctype list -> string *)
let rec types2str = function
    | [] -> ""
    | [ctype] -> type2str ctype
    | ctype :: tail -> type2str ctype ^ " or " ^ (types2str tail)