(****************************************
   utils.ml - helpers divers et variés
 ****************************************)

open Ast
open Lexing
open Typing

(* Formatage de base des constantes, motifs et opérateurs *)

let format_const = function
    | Cint i -> Printf.sprintf "Cint %d" i
    | Cstring s -> Printf.sprintf "Cstring \"%s\"" s
    | Cbool true -> "Cbool true"
    | Cbool false -> "Cbool false"
    | Cunit -> "Cunit ()"
    | Cemptylist -> "Cemptylist []"

let format_unop = function
    | ONot -> "ONot"
    | ONeg -> "ONeg"

let format_binop = function
    | OAdd -> "OAdd"
    | OSub -> "OSub"
    | OMul -> "OMul"
    | ODiv -> "ODiv"
    | OAnd -> "OAnd"
    | OOr -> "OOr"
    | OEq -> "OEq"
    | ONeq -> "ONeq"
    | OLt -> "OLt"
    | OLe -> "OLe"
    | OGt -> "OGt"
    | OGe -> "OGe"

let motif_tuple_folder folder_func base motif =
    Printf.sprintf "%s, %s" base (folder_func motif)

let rec format_motif m =
    match m.m with
        | Munderscore -> "Munderscore _"
        | Mident id -> Printf.sprintf "Mident %s" id
        | Mtuple (m::motifs) ->
            let base = format_motif m
            in
                List.fold_left (motif_tuple_folder format_motif) base motifs
        | Mtuple [] -> "" (* Avoids an useless warning *)

(* Helper pour l'indentation, crée une string de `level` espaces de long *)
let make_indent level =
    Printf.sprintf "%s" (String.make level ' ')

let format_string_option = function
    | None -> "None"
    | Some x -> Printf.sprintf "Some %s" x

let typeof e =
    match e.t with
        | None -> ""
        | Some t ->
            let ts, tvar_names = canon_string t Imap.empty
            in
                Printf.sprintf "{%s}" ts

let rec format_expr level expr =
    let expr_t = typeof expr
    in
        match expr.e with
                | Econst c -> Printf.sprintf "Econst%s %s" expr_t
                                                           (format_const c)
                | Eident id -> Printf.sprintf "Eident%s %s" (typeof expr) id
                | Etuple (e1::l) ->
                    Printf.sprintf "Etuple%s (%s,\n%s)"
                        expr_t
                        (format_expr (level + 8) e1)
                        (format_expr_list "," (level + 8) l)
                | Etuple l -> ""
                | Eunop (o, e) ->
                    let so = (format_unop o)
                    in
                        Printf.sprintf "Eunop%s (%s, %s)" expr_t so
                               (format_expr (level + 9 + String.length so) e)
                | Ebinop (e1, o, e2) ->
                    let s1 = format_expr (level + 8) e1 and so = format_binop o
                    and s2 = format_expr_i (level + 8) e2
                    in
                        Printf.sprintf "Ebinop%s (%s,\n%s%s,\n%s)" expr_t s1
                            (make_indent (level + 8)) so s2
                | Eletin (m, value, body) ->
                    Printf.sprintf "Eletin%s (%s,\n%s,\n%s)" expr_t
                        (format_motif m)
                        (format_expr_i (level + 8) value)
                        (format_expr_i (level + 8) body)
                | Efunc f ->
                    format_func level expr_t f
                | Eif (cond, then_expr, else_expr) ->
                    Printf.sprintf "Eif%s (%s,\n%s,\n%s)" expr_t
                        (format_expr (level + 5) cond)
                        (format_expr_i (level + 5) then_expr)
                        (format_expr_i (level + 5) else_expr)
                | Elistcons (hd_expr, tl_expr) ->
                    Printf.sprintf "Elistcons%s (%s,\n%s)" expr_t
                        (format_expr (level + 11) hd_expr)
                        (format_expr_i (level + 11) tl_expr)
                | Ecall (func_expr, arg) ->
                    Printf.sprintf "Ecall%s (%s,\n%s%s" expr_t
                        (format_expr (level + 7) func_expr)
                        (make_indent (level + 7))
                        (format_expr (level + 7) arg)
                | Ematch (matched_expr, empty_expr, m1, m2, m_expr) ->
                    Printf.sprintf "Ematch%s (%s,\n%s,\n%s((%s)::(%s)),\n%s)"
                        expr_t
                        (format_expr (level + 8) matched_expr)
                        (format_expr_i (level + 8) empty_expr)
                        (make_indent (level + 8))
                        (format_motif m1)
                        (format_motif m2)
                        (format_expr_i (level + 8) m_expr)
                | Eclos _ -> failwith "format_expr : Unreachable matching"
and format_expr_i level expr =
    Printf.sprintf "%s%s" (make_indent level) (format_expr level expr)
and format_expr_list sep level = function
    | [] -> ""
    | [e] -> Printf.sprintf "%s" (format_expr_i level e)
    | e::l ->
        Printf.sprintf "%s%s\n%s" (format_expr_i level e) sep
            (format_expr_list sep level l)
and format_func level expr_t f =
    let get_recursive = function
        | true -> "recursive"
        | false -> "not recursive"
    in
        Printf.sprintf "Efunc%s {name = %s, %s, arg = %s,\n%s}" expr_t
            (format_motif f.name) (get_recursive f.recursive)
            (format_motif f.arg)
            (format_expr_i (level + 7) f.body)

let display_ast ast =
    Printf.printf "%s\n" (format_expr 0 ast)

let typeof_motif m =
    match m.motif_t with
        | None -> ""
        | Some t ->
            let ts, tvar_names = canon_string t Imap.empty
            in
                Printf.sprintf "%s" ts

let rec rebuild_motif m =
    match m.m with
        | Munderscore -> "_"
        | Mident id -> id
        | Mtuple (m::motifs) ->
            let base = rebuild_motif m
            in
                let s = List.fold_left (motif_tuple_folder rebuild_motif)
                                       base
                                       motifs
                in
                    Printf.sprintf "(%s)" s
        | Mtuple [] -> "" (* Avoids an useless warning *)

let rec print_types expr =
    match expr.e with
        | Econst Cunit -> ()
        | Eletin (m, v, body) ->
            Printf.printf "%s : %s\n" (rebuild_motif m) (typeof_motif m);
            print_types body
        | _ -> failwith "print_types : Unreachable matching"

(* Helpers au moment du parsing *)

(* Création d'un record expr/motif non localisé *)
let raw_expr expr =
    { e = expr ; loc = None ; t = None }
let raw_motif m =
    { m = m ; motif_loc = None ; motif_t = None }

(* Création d'un record loc avec les positions fournies par menhir *)
let make_loc startpos endpos =
    let make_pos p =
        { l = p.pos_lnum ;
          c = p.pos_cnum - p.pos_bol ;
          raw_c = p.pos_cnum }
    in
        { spos = make_pos startpos ;
          epos = make_pos endpos }

let make_start_end_loc sloc eloc =
    match sloc, eloc with
        | None, _ -> None
        | _, None -> None
        | (Some sloc), (Some eloc) ->
            Some { spos = sloc.spos ; epos = eloc.epos }

(* Création d'un record expr/motif localisé *)
let locd_expr e loc =
    { e = e ; loc = Some loc ; t = None }
let locd_motif m loc =
    { m = m ; motif_loc = Some loc ; motif_t = None }

(* Création d'un record func en séparatant le premier argument des autres,
   puis en appliquant un fold right afin d'utiliser la curyfication
   (f a b c est gérée comme f = function a -> function b -> function c) *)
let make_func id recur fbody = function
    | [] -> failwith "make_func : Unreachable matching"
    | arg::args ->
        let body =
            List.fold_right (fun arg base ->
                                raw_expr (Efunc {
                                               name = raw_motif (Munderscore) ;
                                               recursive = false ;
                                               arg = arg ;
                                               body = base
                                                }))
                                   args
                                   fbody
        in
            Efunc { name = raw_motif (if recur <> None then Mident id
                                      else Munderscore) ;
                    recursive = recur <> None ;
                    arg = arg ;
                    body = body }

(* Détermination récursive des identificateurs d'une expression *)
let rec identifiers expr =
    match expr.e with
        | Econst _ -> Sset.empty
        | Eident id -> Sset.singleton id
        | Etuple l -> List.fold_left (fun base e ->
                                        Sset.union base (identifiers e))
                                     Sset.empty l
        | Ebinop (e1, _, e2)
        | Elistcons (e1, e2)
        | Ecall (e1, e2)
        | Eletin (_, e1, e2) ->
            Sset.union (identifiers e1) (identifiers e2)
        | Eunop (_, e) -> identifiers e
        | Eif (e1, e2, e3)
        | Ematch (e1, e2, _, _, e3) ->
            Sset.union (Sset.union (identifiers e1) (identifiers e2))
                       (identifiers e3)
        | Efunc { name = { m = Mident id } ; body = body} ->
            Sset.union (Sset.singleton id) (identifiers body)
        | Efunc f ->
            identifiers f.body
        | Eclos _ -> failwith "identifiers : Unreachable matching"