open List
open Ppxlib
open Ppxlib.Ast_builder.Default

open FStarC_Extraction_ML_Syntax

(* Global state used for the name of the ML module being pprinted.
   current_module is only set once in build_ast and read once in
   path_to_ident. This is done in order to avoid clutter. *)
let current_module = ref ""


let flatmap f l = map f l |> List.flatten
let opt_to_list = function Some x -> [x] | None -> []


let no_position : Lexing.position =
  {pos_fname = ""; pos_lnum = 0; pos_bol = 0; pos_cnum = 0}

let no_location : Location.t =
  {loc_start = no_position; loc_end = no_position; loc_ghost = false}

let no_attrs: attributes = []

let loc = no_location


(* functions for generating names and paths *)
let mk_sym s: string Location.loc = {txt=s; loc=no_location}

let mk_sym_lident s: Longident.t Location.loc = {txt=s; loc=no_location}

let mk_lident name = Longident.Lident name |> mk_sym_lident

let mk_typ_name s =
  (* remove an apostrophe from beginning of type name *)
  match (BatString.sub s 0 1) with
  | "'" -> BatString.tail s 1
  | _ -> s

let rec path_to_string ((l, sym): mlpath): string =
  match l with
  | [] -> sym
  | (hd::tl) -> BatString.concat "_" [hd; path_to_string (tl, sym)]

let split_path (l1: string list) (l2: string list): (string list * string list) option =
  let rec split_aux l1 l2 =
    match l2 with
     | [] -> Some l1
     | hd2::tl2 when BatString.equal hd2 (hd l1) -> split_aux (tl l1) tl2
     | _ -> None
  in
  if (length l1 >= length l2) then
    match split_aux l1 l2 with
    | None -> None
    | Some l1' -> Some (l1', l2)
  else None

let path_to_ident ((l, sym): mlpath): Longident.t Asttypes.loc =
  let codegen_libs = FStarC_Options.codegen_libs() in
  match l with
  | [] -> mk_lident sym
  | hd::tl ->
     let m_name = !current_module in
     let suffix, prefix =
       try BatList.find_map (split_path l) codegen_libs with
       | Not_found -> l, []
     in
       let path_abbrev = BatString.concat "_" suffix in
       if (prefix = [] && BatString.equal m_name path_abbrev) then
         (* remove circular references *)
          mk_lident sym
       else
         match prefix with
         | [] ->  Longident.Ldot(Longident.Lident path_abbrev, sym) |> mk_sym_lident
         | p_hd::p_tl ->
            let q = fold_left (fun x y -> Longident.Ldot (x,y)) (Longident.Lident p_hd) p_tl in
            (match path_abbrev with
             | "" -> Longident.Ldot(q, sym) |> mk_sym_lident
             | _ -> Longident.Ldot(Longident.Ldot(q, path_abbrev), sym) |> mk_sym_lident)

let mk_top_mllb (e: mlexpr): mllb =
  {mllb_name="_";
   mllb_tysc=None;
   mllb_add_unit=false;
   mllb_def=e;
   mllb_meta=[];
   mllb_attrs=[];
   print_typ=false }

(* Find the try_with in the default effect module. For instance this can be
FStar.All.try_with (for most users) or FStarC.Effect.try_with (during
bootstrapping with "--MLish --MLish_effect FStarC.Effect"). *)
let try_with_ident () =
  let lid = FStarC_Parser_Const.try_with_lid () in
  let ns = FStarC_Ident.ns_of_lid lid in
  let id = FStarC_Ident.ident_of_lid lid in
  path_to_ident (List.map FStarC_Ident.string_of_id ns, FStarC_Ident.string_of_id id)

(* For integer constants (not 0/1) in this range we will use Prims.of_int
 * Outside this range we will use string parsing to allow arbitrary sized
 * integers.
 * Using int_zero/int_one removes int processing to create the int
 * Using of_int removes string processing to create the int
 *)
let max_of_int_const = Z.of_int   65535
let min_of_int_const = Z.of_int (-65536)

let maybe_guts (s:string) : string =
  if FStarC_Options.codegen () = Some FStarC_Options.Plugin
  then "Fstarcompiler." ^ s
  else s

(* mapping functions from F* ML AST to Parsetree *)
let build_constant (c: mlconstant): constant =
  let stdint_module (s:FStarC_Const.signedness) (w:FStarC_Const.width) : string =
    let sign = match s with
      | FStarC_Const.Signed -> "Int"
      | FStarC_Const.Unsigned -> "Uint" in
    let with_w ws = BatString.concat "" ["Stdint."; sign; ws] in
    match w with
    | FStarC_Const.Int8 -> with_w "8"
    | FStarC_Const.Int16 -> with_w "16"
    | FStarC_Const.Int32 -> with_w "32"
    | FStarC_Const.Int64 -> with_w "64"
    | FStarC_Const.Sizet -> with_w "64" in
  match c with
  | MLC_Int (v, None) ->
      let s = match Z.of_string v with
        | x when x = Z.zero ->
          maybe_guts "Prims.int_zero"
        | x when x = Z.one ->
          maybe_guts "Prims.int_one"
        | x when (min_of_int_const < x) && (x < max_of_int_const) ->
            BatString.concat v ["(Prims.of_int ("; "))"]
        | x ->
            BatString.concat v ["(Prims.parse_int \""; "\")"] in
      Pconst_integer (s, None)
  (* Special case for UInt8, as it's realized as OCaml built-in int type *)
  | MLC_Int (v, Some (FStarC_Const.Unsigned, FStarC_Const.Int8)) ->
      Pconst_integer (v, None)
  | MLC_Int (v, Some (s, w)) ->
      let s = match Z.of_string v with
        | x when x = Z.zero ->
            BatString.concat "" [stdint_module s w; ".zero"]
        | x when x = Z.one ->
            BatString.concat "" [stdint_module s w; ".one"]
        | x when (min_of_int_const < x) && (x < max_of_int_const) ->
            BatString.concat "" ["("; stdint_module s w; ".of_int ("; v; "))"]
        | x ->
            BatString.concat "" ["("; stdint_module s w; ".of_string \""; v; "\")"] in
      Pconst_integer (s, None)
  | MLC_Float v -> Pconst_float (string_of_float v, None)
  | MLC_Char v -> Pconst_integer (string_of_int v, None)
  | MLC_String v -> Pconst_string (v, no_location, None)
  | _ -> failwith "Case not handled"

let build_constant_expr (c: mlconstant): expression =
  match c with
  | MLC_Unit -> pexp_construct ~loc (mk_lident "()") None
  | MLC_Bool b ->
     let id = if b then "true" else "false" in
     pexp_construct ~loc (mk_lident id) None
  | _ -> pexp_constant ~loc (build_constant c)

let build_constant_pat (c: mlconstant): pattern =
  match c with
  | MLC_Unit -> ppat_construct ~loc (mk_lident "()") None
  | MLC_Bool b ->
     let id = if b then "true" else "false" in
     ppat_construct ~loc (mk_lident id) None
  | _ -> ppat_constant ~loc (build_constant c)

let rec build_pattern (p: mlpattern): pattern =
  match p with
  | MLP_Wild -> ppat_any ~loc
  | MLP_Const c -> build_constant_pat c
  | MLP_Var sym -> ppat_var ~loc (mk_sym sym)
  | MLP_CTor args -> build_constructor_pat args
  | MLP_Branch l ->
     (match l with
      | [pat] -> build_pattern pat
      | (pat1::tl) -> ppat_or ~loc (build_pattern pat1) (build_pattern (MLP_Branch tl))
      | [] -> failwith "Empty branch shouldn't happen")
  | MLP_Record (path, l) ->
     let fs = map (fun (x,y) -> (path_to_ident (path, x), build_pattern y)) l in
     ppat_record ~loc fs Open
  | MLP_Tuple l -> ppat_tuple ~loc (map build_pattern l)

and build_constructor_pat ((path, sym), p) =
  let (path', name) =
    (match path with
     | ["Prims"]
     | ["Fstarcompiler.Prims"] ->
       (match sym with
        | "Cons" -> ([], "::")
        | "Nil" -> ([], "[]")
        | x -> (path, x))
     | _ -> (path, sym)) in
  match p with
  | [] ->
     ppat_construct ~loc (path_to_ident (path', name)) None
  | [pat] ->
     Latest.ppat_construct ~loc (path_to_ident (path', name)) (Some ([], build_pattern pat))
  | pats ->
     let inner = ppat_tuple ~loc (map build_pattern pats) in
     Latest.ppat_construct ~loc (path_to_ident(path', name)) (Some ([], inner))

let rec build_core_type ?(annots = []) (ty: mlty): core_type =
  let t =
  match ty with
  | MLTY_Var sym -> ptyp_var ~loc (mk_typ_name sym)
  | MLTY_Fun (ty1, tag, ty2) ->
     let c_ty1 = build_core_type ty1 in
     let c_ty2 = build_core_type ty2 in
     ptyp_arrow ~loc Nolabel c_ty1 c_ty2
  | MLTY_Named (tys, (path, sym)) ->
     (* Note: bypassing F* interface *)
     if FStarC_Parser_Const_Tuples.is_tuple_constructor_string (String.concat "." (path@[sym])) then
       (* A special case for tuples, so they are displayed as
        * ('a * 'b) instead of ('a,'b) FStar_Pervasives_Native.tuple2
        * VD: Should other types named "tupleXX" where XX does not represent
        * the arity of the tuple be added to FStar.Pervasives.Native,
        * the condition below might need to be more specific. *)
       ptyp_tuple ~loc (map build_core_type tys)
     else
       let c_tys = map build_core_type tys in
       let p = path_to_ident (path, sym) in
       ptyp_constr ~loc p c_tys
  | MLTY_Tuple tys -> ptyp_tuple ~loc (map build_core_type tys)
  | MLTY_Top -> ptyp_constr ~loc (mk_lident "Obj.t") []
  | MLTY_Erased -> ptyp_constr ~loc (mk_lident "unit") []
  in
  if annots = []
  then t
  else ptyp_poly ~loc annots t

let build_binding_pattern ?ty (sym : mlident) : pattern =
    let p = ppat_var ~loc (mk_sym sym) in
    match ty with
    | None -> p
    | Some ty -> ppat_constraint ~loc p ty

let resugar_prims_ops path: expression =
  (match path with
  | (["Prims"], "op_Addition") -> mk_lident "+"
  | (["Prims"], "op_Subtraction") -> mk_lident "-"
  | (["Prims"], "op_Multiply") -> mk_lident "*"
  | (["Prims"], "op_Division") -> mk_lident "/"
  | (["Prims"], "op_Equality") -> mk_lident "="
  | (["Prims"], "op_Colon_Equals") -> mk_lident ":="
  | (["Prims"], "op_disEquality") -> mk_lident "<>"
  | (["Prims"], "op_AmpAmp") -> mk_lident "&&"
  | (["Prims"], "op_BarBar") -> mk_lident "||"
  | (["Prims"], "op_LessThanOrEqual") -> mk_lident "<="
  | (["Prims"], "op_GreaterThanOrEqual") -> mk_lident ">="
  | (["Prims"], "op_LessThan") -> mk_lident "<"
  | (["Prims"], "op_GreaterThan") -> mk_lident ">"
  | (["Prims"], "op_Modulus") ->
    (* Use "(mod)" here instead of "mod" to work around as issue in
    newer versions of pprintast, which may print this as "\#mod" instead,
    which is not supported in OCaml versions below 5.2.0. We could
    revert this at some point.

    https://github.com/ocaml/opam-repository/pull/28610#issuecomment-3362301901 *)
    mk_lident "(mod)"
  | (["Prims"], "op_Minus") -> mk_lident "~-"
  | path -> path_to_ident path)
  |> pexp_ident ~loc

let resugar_if_stmts ep cases =
  if List.length cases = 2 then
    let case1 = List.hd cases in
    let case2 = BatList.last cases in
    (match case1.pc_lhs.ppat_desc with
     | Ppat_construct({txt=Lident "true"}, None) ->
         pexp_ifthenelse ~loc ep case1.pc_rhs (Some case2.pc_rhs)
     | _ -> pexp_match ~loc ep cases)
  else
    pexp_match ~loc ep cases

let rec build_expr (e: mlexpr): expression =
  match e.expr with
  | MLE_Const c -> build_constant_expr c
  | MLE_Var sym -> pexp_ident ~loc (mk_lident sym)
  | MLE_Name path ->
     (match path with
      | (["Prims"], op) -> resugar_prims_ops path
      | _ -> pexp_ident ~loc (path_to_ident path))
  | MLE_Let ((flavour, lbs), expr) ->
     let recf = match flavour with
       | Rec -> Recursive
       | NonRec -> Nonrecursive in
     let val_bindings = map (build_binding false recf) lbs in
     pexp_let ~loc recf val_bindings (build_expr expr)
   | MLE_App (e, es) ->
      let args = map (fun x -> (Nolabel, build_expr x)) es in
      let f = build_expr e in
      resugar_app f args es
   | MLE_TApp (e, ts) ->
      build_expr e
   | MLE_Fun (l, e) -> build_fun l e
   | MLE_Match (e, branches) ->
      let ep = build_expr e in
      let cases = map build_case branches in
      resugar_if_stmts ep cases
   | MLE_Coerce (e, _, _) ->
      let r = pexp_ident ~loc (mk_lident "Obj.magic") in
      pexp_apply ~loc r [(Nolabel, build_expr e)]
   | MLE_CTor args -> build_constructor_expr args
   | MLE_Seq args -> build_seq args
   | MLE_Tuple l -> pexp_tuple ~loc (map build_expr l)
   | MLE_Record (path, _, l) ->
      let fields = map (fun (x,y) -> (path_to_ident(path, x), build_expr y)) l in
      pexp_record ~loc fields None
   | MLE_Proj (e, path) ->
      pexp_field ~loc (build_expr e) (path_to_ident (path))
   | MLE_If (e, e1, e2) ->
      pexp_ifthenelse ~loc (build_expr e) (build_expr e1) (BatOption.map build_expr e2)
   | MLE_Raise (path, es) ->
      let r = pexp_ident ~loc (mk_lident "raise") in
      let args = map (fun x -> (Nolabel, build_expr x)) es in
      pexp_apply ~loc r args
   | MLE_Try (e, cs) ->
      pexp_try ~loc (build_expr e) (map build_case cs)

and resugar_app f args es: expression =
  match f.pexp_desc with
  | Pexp_ident x when x = try_with_ident () ->
    (* resugar try_with to a try...with
       try_with : (unit -> ML 'a) -> (exn -> ML 'a) -> ML 'a *)
    assert (length es == 2);
    let s, cs = BatList.first es, BatList.last es in
    (* We have FStar.All.try_with s cs, with s : unit -> ML 'a
     *                                  and  cs : exn -> ML 'a
     *
     * We need to create an OCaml try..with, with a body and a
     * set of cases for catching the exception.
     *
     * For the body, we simply translate `s ()` and we're done.
     *
     * For the cases, we can't a similar trick, so we try to reverse-engineer
     * the shape of the term in order to obtain a proper set. See get_variants. *)

    let body = pexp_apply ~loc (build_expr s) [(Nolabel, build_expr ml_unit)] in
    let variants = get_variants cs in
    pexp_try ~loc body variants

  | _ -> pexp_apply ~loc f args

and get_variants (e : mlexpr) : Parsetree.case list =
    match e.expr with
    | MLE_Fun ([{mlbinder_name=id}], e) ->
       (match e.expr with
        | MLE_Match ({expr = MLE_Var id'}, branches) when id = id' ->
           map build_case branches
        | _ ->
           [build_case (MLP_Var id, None, e)]
       )
    | _ -> failwith "Cannot resugar FStar.All.try_with (3)"

and build_seq args =
  match args with
  | [hd] -> build_expr hd
  | hd::tl -> pexp_sequence ~loc (build_expr hd) (build_seq tl)
  | [] -> failwith "Empty sequence should never happen"

and build_constructor_expr ((path, sym), exp): expression =
  let path', name =
    (match path, sym with
    | ["Prims"], "Cons" -> ([], "::")
    | ["Prims"], "Nil" -> ([], "[]")
    | ["Fstarcompiler.Prims"], "Cons" -> ([], "::")
    | ["Fstarcompiler.Prims"], "Nil" -> ([], "[]")
    | path, x -> (path, x)) in
  match exp with
  | [] -> pexp_construct ~loc (path_to_ident(path', name)) None
  | [e] ->
     pexp_construct ~loc (path_to_ident(path', name)) (Some (build_expr e))
  | es ->
      let inner = pexp_tuple ~loc (map build_expr es) in
      pexp_construct ~loc (path_to_ident(path', name)) (Some inner)

and build_fun l e =
  let mk_binder {mlbinder_name=id; mlbinder_ty=ty} =
    pparam_val ~loc Nolabel None (build_binding_pattern id) in
  pexp_function ~loc (List.map mk_binder l) None (Pfunction_body (build_expr e))

and build_case ((lhs, guard, rhs): mlbranch): case =
  {pc_lhs = (build_pattern lhs);
   pc_guard = BatOption.map build_expr guard;
   pc_rhs = (build_expr rhs)}

(* Takes an expression [fun x y -> t] and a type [a -> b -> c] and pushes the
type annotation into the function as far as possible:
  [fun (x: a) (y: b) : c -> t] *)
and build_expr_with_type (e: mlexpr) (t: mlty) : expression =
  match e.expr, t with
  | MLE_Fun ([], e), _ -> build_expr_with_type e t
  | MLE_Fun ({mlbinder_name; mlbinder_ty}::ls, body), MLTY_Fun (ty1, _tag, ty2) ->
    (* this breaks the typing information, but build_expr only looks at e.expr *)
    let e = { e with expr = MLE_Fun (ls, body) } in
    let argpat = build_binding_pattern ?ty:(Some (build_core_type mlbinder_ty)) mlbinder_name in
    pexp_fun ~loc Nolabel None argpat (build_expr_with_type e ty2)
  | _ ->
    let e = build_expr e in
    let ty = build_core_type t in
    (* Functions with no arguments are still printed as type ascriptions. *)
    pexp_function ~loc [] (Some (Pconstraint ty)) (Pfunction_body e)

and build_binding (toplevel: bool) is_rec (lb: mllb): value_binding =
  let e, ty =
    match lb.mllb_tysc with
    | Some ((_::_) as vars, ty) when toplevel && is_rec = Recursive ->
      (* add type annotation for recursive binds to enable support for polymorphic recursion *)
      let mk1 s = {txt = String.sub s 1 (String.length s - 1); loc = Location.none} in
      let vars = List.map mk1 (ty_param_names vars) in
      build_expr lb.mllb_def, Some (build_core_type ~annots:vars ty)
   | Some (_vars, ty) when toplevel ->
      (* add type annotation to parameters and return type for top-level bindings *)
      build_expr_with_type lb.mllb_def ty, None
    | _ ->
      build_expr lb.mllb_def, None in
  value_binding ~loc ~pat:(build_binding_pattern ?ty:ty lb.mllb_name) ~expr:e

let build_label_decl (sym, ty): label_declaration =
  label_declaration ~loc ~name:(mk_sym sym) ~mutable_:Immutable ~type_:(build_core_type ty)

let build_constructor_decl (sym, tys): constructor_declaration =
  let tys = List.map snd tys in
  let args = if BatList.is_empty tys then Pcstr_tuple []
    else Pcstr_tuple (map build_core_type tys) in
  constructor_declaration ~loc ~name:(mk_sym sym) ~args ~res:None

let build_ty_kind (b: mltybody): type_kind =
  match b with
  | MLTD_Abbrev ty -> Ptype_abstract
  | MLTD_Record l -> Ptype_record (map build_label_decl l)
  | MLTD_DType l -> Ptype_variant (map build_constructor_decl l)

let build_ty_manifest (b: mltybody): core_type option=
  match b with
  | MLTD_Abbrev ty -> Some (build_core_type ty)
  | MLTD_Record l -> None
  | MLTD_DType l -> None


let skip_type_defn (current_module:string) (type_name:string) :bool =
  current_module = "FStar_Pervasives" && type_name = "option"

let type_metadata (md : metadata): attributes option =
  let deriving = BatList.filter_map (function
    | PpxDerivingShow | PpxDerivingShowConstant _ -> Some "show"
    | PpxDerivingYoJson -> Some "yojson"
    | _ -> None
  ) md in
  if List.length deriving > 0 then
    let str = String.concat "," deriving in
    Some [ {
      attr_name = mk_sym "deriving";
      attr_payload = PStr [pstr_eval ~loc (pexp_ident ~loc (mk_lident str)) []];
      attr_loc = no_location }
    ]
  else
    None

let add_deriving_const (md: metadata) (ptype_manifest: core_type option): core_type option =
  match List.filter (function PpxDerivingShowConstant _ -> true | _ -> false) md with
  | [PpxDerivingShowConstant s] ->
      let e = pexp_apply ~loc (pexp_ident ~loc (path_to_ident (["Format"], "pp_print_string"))) [(Nolabel, pexp_ident ~loc (mk_lident "fmt")); (Nolabel, pexp_constant ~loc (Pconst_string (s, no_location, None)))] in
      let deriving_const = {
        attr_name = mk_sym "printer";
        attr_payload = PStr [pstr_eval ~loc (pexp_fun ~loc Nolabel None (build_binding_pattern "fmt") (pexp_fun ~loc Nolabel None (ppat_any ~loc) e)) []];
        attr_loc = no_location } in
      BatOption.map (fun x -> {x with ptyp_attributes=[deriving_const]}) ptype_manifest
  | _ -> ptype_manifest

let build_one_tydecl ({tydecl_name=x;
                       tydecl_ignored=mangle_opt;
                       tydecl_parameters=tparams;
                       tydecl_meta=attrs;
                       tydecl_defn=body}: one_mltydecl): type_declaration =
  let ptype_name = match mangle_opt with
    | Some y -> mk_sym y
    | None -> mk_sym x in
  let ptype_params = map (fun sym -> ptyp_var ~loc (mk_typ_name sym), (NoVariance, NoInjectivity)) (ty_param_names tparams) in
  let ptype_manifest =
    BatOption.map_default build_ty_manifest None body |> add_deriving_const attrs in
  let ptype_kind = BatOption.map_default build_ty_kind Ptype_abstract body in
  let ptype_attrs = match type_metadata attrs with None -> [] | Some a -> a in
  type_declaration ~loc ~name:ptype_name ~params:ptype_params ~cstrs:[]
    ~kind:ptype_kind ~private_:Public ~manifest:ptype_manifest
  |> fun td -> { td with ptype_attributes = ptype_attrs }

let build_tydecl (td: mltydecl): structure_item option =
  let recf = Recursive in
  let type_declarations = map build_one_tydecl td in
  if type_declarations = [] then None else Some (pstr_type ~loc recf type_declarations)

let build_exn (sym, tys): type_exception =
  let tys = List.map snd tys in
  let name = mk_sym sym in
  let args = Pcstr_tuple (map build_core_type tys) in
  let ctor = extension_constructor ~loc ~name ~kind:(Pext_decl ([], args, None)) in
  type_exception ~loc ctor

let build_module1 (m1: mlmodule1): structure_item option =
  match m1.mlmodule1_m with
  | MLM_Ty tydecl ->
     (match build_tydecl tydecl with
      | Some t -> Some t
      | None   -> None)
  | MLM_Let (flav, mllbs) ->
     let recf = match flav with | Rec -> Recursive | NonRec -> Nonrecursive in
     let bindings = map (build_binding true recf) mllbs in
     Some (pstr_value ~loc recf bindings)
  | MLM_Exn exn -> Some (pstr_exception ~loc (build_exn exn))
  | MLM_Top expr ->
      let lb = mk_top_mllb expr in
      let binding = build_binding true Nonrecursive lb in
      Some (pstr_value ~loc Nonrecursive [binding])
  | MLM_Loc (p, f) -> None

let mk_open name =
  pstr_open ~loc (open_infos ~loc ~override:Fresh ~expr:(pmod_ident ~loc (mk_lident name)))

let build_m (md: (mlsig * mlmodulebody) option) : structure =
  match md with
  | Some(_sig, m) ->
    let open_plugin_lib =
      if FStarC_Options.codegen () = Some FStarC_Options.Plugin (* NB: PluginNoLib does not open the library *)
      then [mk_open "Fstar_pluginlib"]
      else []
    in
    let open_guts =
      if FStarC_Options.codegen () = Some FStarC_Options.PluginNoLib
      then [mk_open "Fstarcompiler"]
      else []
    in
    let open_prims = [mk_open "Prims"] in
    open_plugin_lib @ open_guts @ open_prims @ (map build_module1 m |> flatmap opt_to_list)
  | None -> []

let build_ast (modul : mlmodule) =
  let (p, md) = modul in
  let m = path_to_string p in
  current_module := m;
  build_m md

let print_module (s: structure) : string =
  let fmt = Format.str_formatter in
  Pprintast.structure fmt s;
  let res = Format.flush_str_formatter () in
  res

let print_ml (modul : mlmodule) : string =
  let ast = build_ast modul in
  print_module ast
