path: root/source/xi_lib/ast_rawprinter.ml

open Ast


let string_of_binop = function
  | BINOP_And -> "BINOP_And"
  | BINOP_Or -> "BINOP_Or"
  | BINOP_Add -> "BINOP_Add"
  | BINOP_Sub -> "BINOP_Sub"
  | BINOP_Mult -> "BINOP_Mult"
  | BINOP_Div -> "BINOP_Div"
  | BINOP_Rem -> "BINOP_Rem"

let string_of_relop = function
  | RELOP_Eq -> "RELOP_Eq"
  | RELOP_Ne -> "RELOP_Ne"
  | RELOP_Lt -> "RELOP_Lt"
  | RELOP_Gt -> "RELOP_Gt"
  | RELOP_Le -> "RELOP_Le"
  | RELOP_Ge -> "RELOP_Ge"

let string_of_unop = function
  | UNOP_Not -> "UNOP_Not"
  | UNOP_Neg -> "UNOP_Neg"

let indent x = "  " ^ x
let indentfmt fmt =
  let cont = Format.sprintf "   %s"  in 
  Format.ksprintf cont fmt

let indentxs = List.map indent 

type p =
  | P_String of string
  | P_Sequence of p list
  | P_List of p list
  | P_Dict of string * (string * p) list

type r =
  | R_String of string
  | R_Indent of r 
  | R_Break
  | R_Tab
  | R_Group of r list

let render_r = function
  | R_String s -> s
  | R_Tab -> "   "
  | R_Break -> "\n"
  | R_Group _ -> failwith "R_Group should be eliminated"
  | R_Indent _ -> failwith "R_Indent should be eliminated"

let rec insert_tabs tabs = function
  | R_Indent r ->
    insert_tabs (R_Tab::tabs) r
  | R_Break ->
    R_Group [R_Break; R_Group tabs]
  | R_Group rs ->
    R_Group (List.map (insert_tabs tabs) rs)
  | r ->
    r

let rec flatten = function
  | R_Indent _ -> failwith "R_Indent should be eliminated"
  | R_Group xs -> List.concat @@ List.map flatten xs
  | r -> [r]

let render_r r =
  String.concat "" @@ List.map render_r @@ flatten @@ insert_tabs [] r

let rec render_p = function
  | P_String s ->
    R_String s
  | P_List xs ->
    let rec f acc = function
      | [] ->
        R_Group (List.rev acc)

      | x::xs ->
        let entry = R_Group [render_p x; R_String ";"; R_Break] in
        f (entry::acc) xs
    in
    R_Group
      [ R_String "["
      ; R_Indent (R_Group [R_Break; f [] xs])
      ; R_String "]"
      ]

  | P_Dict (kind, items) ->
    let rec f acc = function
      | [] ->
        R_Group (List.rev acc)
      | (k,v)::xs ->
        let entry = R_Group [R_String k; R_String " = "; R_Indent (render_p v); R_String ";"; R_Break] in
        f (entry::acc) xs
    in
    R_Group 
      [ R_String kind
      ; R_String " "
      ; R_String "{"
      ; R_Indent (R_Group [R_Break; f [] items])
      ; R_String "}"
      ]
  
  | P_Sequence xs ->
    R_Group (List.map render_p xs)

let p_dict k items = P_Dict (k,items)

let p_identifier id = P_String (Format.sprintf "\"%s\"" @@ string_of_identifier id)
let p_string id = P_String (Format.sprintf "\"%s\"" id)
let p_location loc = P_String (string_of_location loc)
let p_node_tag tag = P_String (string_of_node_tag tag)
let p_i32 i = P_String (Int32.to_string i)
let p_char c = P_String (Format.sprintf "'%c'" c)
let p_bool b = P_String (string_of_bool b)

let p_opt f = function
  | None -> P_String "None"
  | Some x -> P_Sequence [P_String "Some "; f x]


let rec p_expression = function 
  | EXPR_Id {loc; tag; id} -> p_dict "EXPR_Id"
    [ "loc", p_location loc
    ; "tag", p_node_tag tag
    ; "id", p_identifier id
    ]
  
  | EXPR_Int {tag; loc; value} -> p_dict "EXPR_Int"
    [ "loc", p_location loc
    ; "tag", p_node_tag tag
    ; "value", p_i32 value
    ]
  
  | EXPR_Char {tag; loc; value} -> p_dict "EXPR_Char"
    [ "loc", p_location loc
    ; "tag", p_node_tag tag
    ; "value", p_char value
    ]

  | EXPR_String {tag; loc; value} -> p_dict "EXPR_String"
    [ "loc", p_location loc
    ; "tag", p_node_tag tag
    ; "value", p_string value
    ]

  | EXPR_Bool {tag; loc; value} -> p_dict "EXPR_Bool"
    [ "loc", p_location loc
    ; "tag", p_node_tag tag
    ; "value", p_bool value
    ]

  | EXPR_Relation {tag; loc; op; lhs; rhs} -> p_dict "EXPR_Relation"
    [ "loc", p_location loc
    ; "tag", p_node_tag tag
    ; "op", P_String (string_of_relop op)
    ; "lhs", p_expression lhs
    ; "rhs", p_expression rhs
    ]

  | EXPR_Binop {tag; loc; op; lhs; rhs} -> p_dict "EXPR_Binop"
    [ "loc", p_location loc
    ; "tag", p_node_tag tag
    ; "op", P_String (string_of_binop op)
    ; "lhs", p_expression lhs
    ; "rhs", p_expression rhs
    ]

  | EXPR_Unop {tag; loc; op; sub} -> p_dict "EXPR_Unop"
    [ "loc", p_location loc
    ; "tag", p_node_tag tag
    ; "op", P_String (string_of_unop op)
    ; "sub", p_expression sub
    ]
  
  | EXPR_Length {tag; loc; arg} -> p_dict "EXPR_Length"
    [ "loc", p_location loc
    ; "tag", p_node_tag tag
    ; "arg", p_expression arg
    ]

  | EXPR_Index {tag; loc; expr; index} -> p_dict "EXPR_Index"
    [ "loc", p_location loc
    ; "tag", p_node_tag tag
    ; "expr", p_expression expr
    ; "index", p_expression index
    ]

  | EXPR_Struct {tag; loc; elements} -> p_dict "EXPR_Struct"
    [ "loc", p_location loc
    ; "tag", p_node_tag tag
    ; "elements", P_List (List.map p_expression elements)
    ]

  | EXPR_Call call -> P_Sequence
    [ P_String "EXPR_Call "
    ; p_call call
    ]

and p_call = function
  | Call {tag; loc; callee; arguments} -> p_dict "Call"
    [ "loc", p_location loc
    ; "tag", p_node_tag tag
    ; "callee", p_identifier callee
    ; "arguments", P_List (List.map p_expression arguments)
    ]

let rec p_type_expression = function
  | TEXPR_Int {loc} -> p_dict "TEXPR_Int"
    [ "loc", p_location loc
    ]
  
  | TEXPR_Bool {loc} -> p_dict "TEXPR_Bool"
    [ "loc", p_location loc
    ]
  
  | TEXPR_Array {loc;sub;dim} -> p_dict "TPEXPR_Array"
    [ "loc", p_location loc
    ; "sub", p_type_expression sub
    ; "dim", p_opt p_expression dim
    ]

let p_lvalue = function
  | LVALUE_Id {loc; id} -> p_dict "LVALUE_Id"
    [ "loc", p_location loc
    ; "id", p_identifier id
    ]
  | LVALUE_Index {loc; sub; index} -> p_dict "LVALUE_Index"
    [ "loc", p_location loc
    ; "sub", p_expression sub
    ; "index", p_expression index
    ]

let p_var_declaration = function
  | VarDecl {loc;id;tp} -> p_dict "VarDecl"
    [ "loc", p_location loc
    ; "id",  p_identifier id
    ; "tp", p_type_expression tp
    ]

let rec p_statement = function
  | STMT_Call call -> P_Sequence
    [ P_String "STMT_Call "
    ; p_call call
    ]
  
  | STMT_Assign {loc; lhs; rhs} -> p_dict "STMT_Assign"
    [ "loc", p_location loc
    ; "lhs", p_lvalue lhs
    ; "rhs", p_expression rhs
    ]

  | STMT_VarDecl {var; init} -> p_dict "STMT_VarDecl"
    [ "var", p_var_declaration var
    ; "init", p_opt p_expression init
    ]

  | STMT_If {loc; cond; then_branch; else_branch} -> p_dict "STMT_If"
    [ "loc", p_location loc
    ; "cond", p_expression cond
    ; "then_branch", p_statement then_branch
    ; "else_branch", p_opt p_statement else_branch
    ]

  | STMT_While {loc; cond; body} -> p_dict "STMT_While"
    [ "loc", p_location loc
    ; "cond", p_expression cond
    ; "body", p_statement body
    ]
  
  | STMT_Block block -> P_Sequence
    [ P_String "STMT_Block "
    ; p_statement_block block
    ]
  
  | STMT_MultiVarDecl {loc; vars; init} -> p_dict "STMT_MultiVarDecl"
    [ "loc", p_location loc
    ; "vars", P_List (List.map (p_opt p_var_declaration) vars)
    ; "init", p_call init
    ]
  
  | STMT_Return {loc; values} -> p_dict "STMT_Return"
    [ "loc", p_location loc
    ; "values", P_List (List.map p_expression values)
    ]

and p_statement_block = function
  | STMTBlock {loc; body} -> p_dict "STMTBlock"
    [ "loc", p_location loc
    ; "body", P_List (List.map p_statement body)
    ]



let p_global_declaration = function
  | GDECL_Function {loc;id;formal_parameters; return_types; body} ->
    p_dict "GDECL_Function"
      [ "loc", p_location loc
      ; "id", p_identifier id
      ; "formal_parameters", P_List (List.map p_var_declaration formal_parameters)
      ; "return_types", P_List (List.map p_type_expression return_types)
      ; "body", p_opt p_statement_block body
      ]

let p_module_definition = function
  | ModuleDefinition {global_declarations} -> P_Sequence 
    [ P_String "ModuleDefinition "
    ; P_List (List.map p_global_declaration global_declarations)
    ]

let show_module_definition mdef =
  let p = p_module_definition mdef in
  render_r @@ render_p p