initial commit

.gitignore

@@ -0,0 +1,2 @@
+*~
+_build/

bin/dune

@@ -0,0 +1,10 @@
+(executable
+ (public_name typedastsch)
+ (name main)
+ (modes byte)
+ (flags -I +compiler-libs -linkall
+        ocamlcommon.cma
+        ocamlbytecomp.cma
+        ocamltoplevel.cma  )
+ (libraries             
+            ))

bin/main.ml

@@ -0,0 +1,848 @@
+let () = print_endline "Hello, World!"
+
+module Toploop = struct
+  open Format
+  include Toploop
+  (**************************************************************************)
+  (*                                                                        *)
+  (*                                 OCaml                                  *)
+  (*                                                                        *)
+  (*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+  (*                                                                        *)
+  (*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+  (*     en Automatique.                                                    *)
+  (*                                                                        *)
+  (*   All rights reserved.  This file is distributed under the terms of    *)
+  (*   the GNU Lesser General Public License version 2.1, with the          *)
+  (*   special exception on linking described in the file LICENSE.          *)
+  (*                                                                        *)
+  (**************************************************************************)
+
+  (* The interactive toplevel loop *)
+
+  open Format
+  open Misc
+  open Parsetree
+  open Types
+  open Typedtree
+  open Outcometree
+  open Ast_helper
+  module String = Misc.Stdlib.String
+
+  type directive_fun =
+    | Directive_none of (unit -> unit)
+    | Directive_string of (string -> unit)
+    | Directive_int of (int -> unit)
+    | Directive_ident of (Longident.t -> unit)
+    | Directive_bool of (bool -> unit)
+
+  type directive_info = { section : string; doc : string }
+
+  (* Phase buffer that stores the last toplevel phrase (see
+     [Location.input_phrase_buffer]). *)
+  let phrase_buffer = Buffer.create 1024
+
+  (* The table of toplevel value bindings and its accessors *)
+
+  let toplevel_value_bindings : Obj.t String.Map.t ref =
+    ref String.Map.empty
+
+  let getvalue name =
+    try String.Map.find name !toplevel_value_bindings
+    with Not_found -> fatal_error (name ^ " unbound at toplevel")
+
+  let setvalue name v =
+    toplevel_value_bindings :=
+      String.Map.add name v !toplevel_value_bindings
+
+  (* Return the value referred to by a path *)
+
+  let rec eval_address = function
+    | Env.Aident id -> (
+        if Ident.persistent id || Ident.global id then
+          Symtable.get_global_value id
+        else
+          let name = Translmod.toplevel_name id in
+          try String.Map.find name !toplevel_value_bindings
+          with Not_found ->
+            raise (Symtable.Error (Symtable.Undefined_global name)))
+    | Env.Adot (p, pos) -> Obj.field (eval_address p) pos
+
+  let eval_path find env path =
+    match find path env with
+    | addr -> eval_address addr
+    | exception Not_found ->
+        fatal_error ("Cannot find address for: " ^ Path.name path)
+
+  let eval_module_path env path =
+    eval_path Env.find_module_address env path
+
+  let eval_value_path env path =
+    eval_path Env.find_value_address env path
+
+  let eval_extension_path env path =
+    eval_path Env.find_constructor_address env path
+
+  let eval_class_path env path =
+    eval_path Env.find_class_address env path
+
+  (* To print values *)
+
+  module EvalPath = struct
+    type valu = Obj.t
+
+    exception Error
+
+    let eval_address addr =
+      try eval_address addr with Symtable.Error _ -> raise Error
+
+    let same_value v1 v2 = v1 == v2
+  end
+
+  module Printer = Genprintval.Make (Obj) (EvalPath)
+
+  let max_printer_depth = ref 100
+  let max_printer_steps = ref 300
+  let print_out_value = Oprint.out_value
+  let print_out_type = Oprint.out_type
+  let print_out_class_type = Oprint.out_class_type
+  let print_out_module_type = Oprint.out_module_type
+  let print_out_type_extension = Oprint.out_type_extension
+  let print_out_sig_item = Oprint.out_sig_item
+  let print_out_signature = Oprint.out_signature
+  let print_out_phrase = Oprint.out_phrase
+
+  let print_untyped_exception ppf obj =
+    !print_out_value ppf (Printer.outval_of_untyped_exception obj)
+
+  let outval_of_value env obj ty =
+    Printer.outval_of_value !max_printer_steps !max_printer_depth
+      (fun _ _ _ -> None)
+      env obj ty
+
+  let print_value env obj ppf ty =
+    !print_out_value ppf (outval_of_value env obj ty)
+
+  type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer =
+    | Zero of 'b
+    | Succ of ('a -> ('a, 'b) gen_printer)
+
+  let install_printer = Printer.install_printer
+  let install_generic_printer = Printer.install_generic_printer
+  let install_generic_printer' = Printer.install_generic_printer'
+  let remove_printer = Printer.remove_printer
+
+  (* Hooks for parsing functions *)
+
+  let parse_toplevel_phrase = ref Parse.toplevel_phrase
+  let parse_use_file = ref Parse.use_file
+  let print_location = Location.print_loc
+  let print_error = Location.print_report
+  let print_warning = Location.print_warning
+  let input_name = Location.input_name
+
+  let parse_mod_use_file name lb =
+    let modname =
+      String.capitalize_ascii
+        (Filename.remove_extension (Filename.basename name))
+    in
+    let items =
+      List.concat
+        (List.map
+           (function Ptop_def s -> s | Ptop_dir _ -> [])
+           (!parse_use_file lb))
+    in
+    [
+      Ptop_def
+        [
+          Str.module_
+            (Mb.mk
+               (Location.mknoloc (Some modname))
+               (Mod.structure items));
+        ];
+    ]
+
+  (* Hook for initialization *)
+
+  let toplevel_startup_hook = ref (fun () -> ())
+
+  type event = ..
+  type event += Startup | After_setup
+
+  let hooks = ref []
+  let add_hook f = hooks := f :: !hooks
+
+  let () =
+    add_hook (function
+      | Startup -> !toplevel_startup_hook ()
+      | _ -> ())
+
+  let run_hooks hook = List.iter (fun f -> f hook) !hooks
+
+  (* Load in-core and execute a lambda term *)
+
+  let may_trace = ref false (* Global lock on tracing *)
+
+  type evaluation_outcome = Result of Obj.t | Exception of exn
+
+  let backtrace = ref None
+
+  let record_backtrace () =
+    if Printexc.backtrace_status () then
+      backtrace := Some (Printexc.get_backtrace ())
+
+  let load_lambda ppf lam =
+    if !Clflags.dump_rawlambda then
+      fprintf ppf "%a@." Printlambda.lambda lam;
+    let slam = Simplif.simplify_lambda lam in
+    if !Clflags.dump_lambda then
+      fprintf ppf "%a@." Printlambda.lambda slam;
+    let init_code, fun_code = Bytegen.compile_phrase slam in
+    if !Clflags.dump_instr then
+      fprintf ppf "%a%a@." Printinstr.instrlist init_code
+        Printinstr.instrlist fun_code;
+    let code, reloc, events = Emitcode.to_memory init_code fun_code in
+    let can_free = fun_code = [] in
+    let initial_symtable = Symtable.current_state () in
+    Symtable.patch_object code reloc;
+    Symtable.check_global_initialized reloc;
+    Symtable.update_global_table ();
+    let initial_bindings = !toplevel_value_bindings in
+    let bytecode, closure =
+      Meta.reify_bytecode code [| events |] None
+    in
+    match
+      may_trace := true;
+      Fun.protect
+        ~finally:(fun () ->
+          may_trace := false;
+          if can_free then Meta.release_bytecode bytecode)
+        closure
+    with
+    | retval -> Result retval
+    | exception x ->
+        record_backtrace ();
+        toplevel_value_bindings := initial_bindings;
+        (* PR#6211 *)
+        Symtable.restore_state initial_symtable;
+        Exception x
+
+  (* Print the outcome of an evaluation *)
+
+  let pr_item =
+    Printtyp.print_items (fun env -> function
+      | Sig_value (id, { val_kind = Val_reg; val_type }, _) ->
+          Some
+            (outval_of_value env
+               (getvalue (Translmod.toplevel_name id))
+               val_type)
+      | _ -> None)
+
+  (* The current typing environment for the toplevel *)
+
+  let toplevel_env = ref Env.empty
+
+  (* Print an exception produced by an evaluation *)
+
+  let print_out_exception ppf exn outv =
+    !print_out_phrase ppf (Ophr_exception (exn, outv))
+
+  let print_exception_outcome ppf exn =
+    if exn = Out_of_memory then Gc.full_major ();
+    let outv =
+      outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn
+    in
+    print_out_exception ppf exn outv;
+    if Printexc.backtrace_status () then
+      match !backtrace with
+      | None -> ()
+      | Some b ->
+          print_string b;
+          backtrace := None
+
+  (* Inserting new toplevel directives *)
+
+  let directive_table =
+    (Hashtbl.create 23 : (string, directive_fun) Hashtbl.t)
+
+  let directive_info_table =
+    (Hashtbl.create 23 : (string, directive_info) Hashtbl.t)
+
+  let add_directive name dir_fun dir_info =
+    Hashtbl.add directive_table name dir_fun;
+    Hashtbl.add directive_info_table name dir_info
+
+  (* Execute a toplevel phrase *)
+
+  let execute_phrase print_outcome ppf phr =
+    match phr with
+    | Ptop_def sstr -> (
+        let oldenv = !toplevel_env in
+        Typecore.reset_delayed_checks ();
+        let str, sg, sn, _, newenv =
+          Typemod.type_toplevel_phrase oldenv sstr
+        in
+        if !Clflags.dump_typedtree then
+          Printtyped.implementation ppf str;
+        let sg' = Typemod.Signature_names.simplify newenv sn sg in
+        ignore
+          (Includemod.signatures ~mark:Mark_positive oldenv sg sg');
+        Typecore.force_delayed_checks ();
+        let lam = Translmod.transl_toplevel_definition str in
+        Warnings.check_fatal ();
+        try
+          toplevel_env := newenv;
+          let res = load_lambda ppf lam in
+          let out_phr =
+            match res with
+            | Result v ->
+                if print_outcome then
+                  Printtyp.wrap_printing_env ~error:false oldenv
+                    (fun () ->
+                      match str.str_items with
+                      | [
+                       {
+                         str_desc =
+                           ( Tstr_eval (exp, _)
+                           | Tstr_value
+                               ( Asttypes.Nonrecursive,
+                                 [
+                                   {
+                                     vb_pat = { pat_desc = Tpat_any };
+                                     vb_expr = exp;
+                                   };
+                                 ] ) );
+                       };
+                      ] ->
+                          let outv =
+                            outval_of_value newenv v exp.exp_type
+                          in
+                          let ty =
+                            Printtyp.tree_of_type_scheme exp.exp_type
+                          in
+                          Ophr_eval (outv, ty)
+                      | [] -> Ophr_signature []
+                      | _ -> Ophr_signature (pr_item oldenv sg'))
+                else Ophr_signature []
+            | Exception exn ->
+                toplevel_env := oldenv;
+                if exn = Out_of_memory then Gc.full_major ();
+                let outv =
+                  outval_of_value !toplevel_env (Obj.repr exn)
+                    Predef.type_exn
+                in
+                Ophr_exception (exn, outv)
+          in
+          !print_out_phrase ppf out_phr;
+          (if Printexc.backtrace_status () then
+           match !backtrace with
+           | None -> ()
+           | Some b ->
+               pp_print_string ppf b;
+               pp_print_flush ppf ();
+               backtrace := None);
+          match out_phr with
+          | Ophr_eval (_, _) | Ophr_signature _ -> true
+          | Ophr_exception _ -> false
+        with x ->
+          toplevel_env := oldenv;
+          raise x)
+    | Ptop_dir { pdir_name = { Location.txt = dir_name }; pdir_arg }
+      -> (
+        let d =
+          try Some (Hashtbl.find directive_table dir_name)
+          with Not_found -> None
+        in
+        match d with
+        | None ->
+            fprintf ppf "Unknown directive `%s'." dir_name;
+            let directives =
+              Hashtbl.fold
+                (fun dir _ acc -> dir :: acc)
+                directive_table []
+            in
+            Misc.did_you_mean ppf (fun () ->
+                Misc.spellcheck directives dir_name);
+            fprintf ppf "@.";
+            false
+        | Some d -> (
+            match (d, pdir_arg) with
+            | Directive_none f, None ->
+                f ();
+                true
+            | Directive_string f, Some { pdira_desc = Pdir_string s }
+              ->
+                f s;
+                true
+            | ( Directive_int f,
+                Some { pdira_desc = Pdir_int (n, None) } ) -> (
+                match Int_literal_converter.int n with
+                | n ->
+                    f n;
+                    true
+                | exception _ ->
+                    fprintf ppf
+                      "Integer literal exceeds the range of \
+                       representable integers for directive `%s'.@."
+                      dir_name;
+                    false)
+            | ( Directive_int _,
+                Some { pdira_desc = Pdir_int (_, Some _) } ) ->
+                fprintf ppf
+                  "Wrong integer literal for directive `%s'.@."
+                  dir_name;
+                false
+            | Directive_ident f, Some { pdira_desc = Pdir_ident lid }
+              ->
+                f lid;
+                true
+            | Directive_bool f, Some { pdira_desc = Pdir_bool b } ->
+                f b;
+                true
+            | _ ->
+                fprintf ppf
+                  "Wrong type of argument for directive `%s'.@."
+                  dir_name;
+                false))
+
+  let execute_phrase print_outcome ppf phr =
+    try execute_phrase print_outcome ppf phr
+    with exn ->
+      Warnings.reset_fatal ();
+      raise exn
+
+  (* Read and execute commands from a file, or from stdin if [name] is "". *)
+
+  let use_print_results = ref true
+
+  let preprocess_phrase ppf phr =
+    let phr =
+      match phr with
+      | Ptop_def str ->
+          let str =
+            Pparse.apply_rewriters_str ~restore:true
+              ~tool_name:"ocaml" str
+          in
+          Ptop_def str
+      | phr -> phr
+    in
+    if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
+    if !Clflags.dump_source then Pprintast.top_phrase ppf phr;
+    phr
+
+  let use_channel ppf ~wrap_in_module ic name filename =
+    let lb = Lexing.from_channel ic in
+    Warnings.reset_fatal ();
+    Location.init lb filename;
+    (* Skip initial #! line if any *)
+    Lexer.skip_hash_bang lb;
+    protect_refs
+      [
+        R (Location.input_name, filename);
+        R (Location.input_lexbuf, Some lb);
+      ]
+      (fun () ->
+        try
+          List.iter
+            (fun ph ->
+              let ph = preprocess_phrase ppf ph in
+              if not (execute_phrase !use_print_results ppf ph) then
+                raise Exit)
+            (if wrap_in_module then parse_mod_use_file name lb
+            else !parse_use_file lb);
+          true
+        with
+        | Exit -> false
+        | Sys.Break ->
+            fprintf ppf "Interrupted.@.";
+            false
+        | x ->
+            Location.report_exception ppf x;
+            false)
+
+  let use_output ppf command =
+    let fn = Filename.temp_file "ocaml" "_toploop.ml" in
+    Misc.try_finally
+      ~always:(fun () -> try Sys.remove fn with Sys_error _ -> ())
+      (fun () ->
+        match
+          Printf.ksprintf Sys.command "%s > %s" command
+            (Filename.quote fn)
+        with
+        | 0 ->
+            let ic = open_in_bin fn in
+            Misc.try_finally
+              ~always:(fun () -> close_in ic)
+              (fun () ->
+                use_channel ppf ~wrap_in_module:false ic ""
+                  "(command-output)")
+        | n ->
+            fprintf ppf "Command exited with code %d.@." n;
+            false)
+
+  let use_file ppf ~wrap_in_module name =
+    match name with
+    | "" -> use_channel ppf ~wrap_in_module stdin name "(stdin)"
+    | _ -> (
+        match Load_path.find name with
+        | filename ->
+            let ic = open_in_bin filename in
+            Misc.try_finally
+              ~always:(fun () -> close_in ic)
+              (fun () ->
+                use_channel ppf ~wrap_in_module ic name filename)
+        | exception Not_found ->
+            fprintf ppf "Cannot find file %s.@." name;
+            false)
+
+  let mod_use_file ppf name = use_file ppf ~wrap_in_module:true name
+  let use_file ppf name = use_file ppf ~wrap_in_module:false name
+
+  let use_silently ppf name =
+    protect_refs
+      [ R (use_print_results, false) ]
+      (fun () -> use_file ppf name)
+
+  (* Reading function for interactive use *)
+
+  let first_line = ref true
+  let got_eof = ref false
+
+  let read_input_default prompt buffer len =
+    output_string stdout prompt;
+    flush stdout;
+    let i = ref 0 in
+    try
+      while true do
+        if !i >= len then raise Exit;
+        let c = input_char stdin in
+        Bytes.set buffer !i c;
+        (* Also populate the phrase buffer as new characters are added. *)
+        Buffer.add_char phrase_buffer c;
+        incr i;
+        if c = '\n' then raise Exit
+      done;
+      (!i, false)
+    with
+    | End_of_file -> (!i, true)
+    | Exit -> (!i, false)
+
+  let read_interactive_input = ref read_input_default
+
+  let refill_lexbuf buffer len =
+    if !got_eof then (
+      got_eof := false;
+      0)
+    else
+      let prompt =
+        if !Clflags.noprompt then ""
+        else if !first_line then "# "
+        else if !Clflags.nopromptcont then ""
+        else if Lexer.in_comment () then "* "
+        else "  "
+      in
+      first_line := false;
+      let len, eof = !read_interactive_input prompt buffer len in
+      if eof then (
+        Location.echo_eof ();
+        if len > 0 then got_eof := true;
+        len)
+      else len
+
+  (* Toplevel initialization. Performed here instead of at the
+     beginning of loop() so that user code linked in with ocamlmktop
+     can call directives from Topdirs. *)
+
+  let _ =
+    if !Sys.interactive then
+      (* PR#6108 *)
+      invalid_arg
+        "The ocamltoplevel.cma library from compiler-libs cannot be \
+         loaded inside the OCaml toplevel";
+    Sys.interactive := true;
+    let crc_intfs = Symtable.init_toplevel () in
+    Compmisc.init_path ();
+    Env.import_crcs ~source:Sys.executable_name crc_intfs;
+    ()
+
+  let find_ocamlinit () =
+    let ocamlinit = ".ocamlinit" in
+    if Sys.file_exists ocamlinit then Some ocamlinit
+    else
+      let getenv var =
+        match Sys.getenv var with
+        | exception Not_found -> None
+        | "" -> None
+        | v -> Some v
+      in
+      let exists_in_dir dir file =
+        match dir with
+        | None -> None
+        | Some dir ->
+            let file = Filename.concat dir file in
+            if Sys.file_exists file then Some file else None
+      in
+      let home_dir () = getenv "HOME" in
+      let config_dir () =
+        if Sys.win32 then None
+        else
+          match getenv "XDG_CONFIG_HOME" with
+          | Some _ as v -> v
+          | None -> (
+              match home_dir () with
+              | None -> None
+              | Some dir -> Some (Filename.concat dir ".config"))
+      in
+      let init_ml = Filename.concat "ocaml" "init.ml" in
+      match exists_in_dir (config_dir ()) init_ml with
+      | Some _ as v -> v
+      | None -> exists_in_dir (home_dir ()) ocamlinit
+
+  let load_ocamlinit ppf =
+    if !Clflags.noinit then ()
+    else
+      match !Clflags.init_file with
+      | Some f ->
+          if Sys.file_exists f then ignore (use_silently ppf f)
+          else fprintf ppf "Init file not found: \"%s\".@." f
+      | None -> (
+          match find_ocamlinit () with
+          | None -> ()
+          | Some file -> ignore (use_silently ppf file))
+
+  let set_paths () =
+    (* Add whatever -I options have been specified on the command line,
+       but keep the directories that user code linked in with ocamlmktop
+       may have added to load_path. *)
+    let expand = Misc.expand_directory Config.standard_library in
+    let current_load_path = Load_path.get_paths () in
+    let load_path =
+      List.concat
+        [
+          [ "" ];
+          List.map expand (List.rev !Compenv.first_include_dirs);
+          List.map expand (List.rev !Clflags.include_dirs);
+          List.map expand (List.rev !Compenv.last_include_dirs);
+          current_load_path;
+          [ expand "+camlp4" ];
+        ]
+    in
+    Load_path.init load_path;
+    Dll.add_path load_path
+
+  let initialize_toplevel_env () =
+    toplevel_env := Compmisc.initial_env ()
+
+  (* The interactive loop *)
+
+  exception PPerror
+
+  let loop ppf =
+    Clflags.debug := true;
+    Location.formatter_for_warnings := ppf;
+    if not !Clflags.noversion then
+      fprintf ppf "        OCaml version %s@.@." Config.version;
+    (try initialize_toplevel_env ()
+     with (Env.Error _ | Typetexp.Error _) as exn ->
+       Location.report_exception ppf exn;
+       raise (Compenv.Exit_with_status 2));
+    let lb = Lexing.from_function refill_lexbuf in
+    Location.init lb "//toplevel//";
+    Location.input_name := "//toplevel//";
+    Location.input_lexbuf := Some lb;
+    Location.input_phrase_buffer := Some phrase_buffer;
+    Sys.catch_break true;
+    run_hooks After_setup;
+    load_ocamlinit ppf;
+    while true do
+      let snap = Btype.snapshot () in
+      try
+        Lexing.flush_input lb;
+        (* Reset the phrase buffer when we flush the lexing buffer. *)
+        Buffer.reset phrase_buffer;
+        Location.reset ();
+        Warnings.reset_fatal ();
+        first_line := true;
+        let phr =
+          try !parse_toplevel_phrase lb with Exit -> raise PPerror
+        in
+        let phr = preprocess_phrase ppf phr in
+        Env.reset_cache_toplevel ();
+        ignore (execute_phrase true ppf phr)
+      with
+      | End_of_file -> raise (Compenv.Exit_with_status 0)
+      | Sys.Break ->
+          fprintf ppf "Interrupted.@.";
+          Btype.backtrack snap
+      | PPerror -> ()
+      | x ->
+          Location.report_exception ppf x;
+          Btype.backtrack snap
+    done
+
+  external caml_sys_modify_argv : string array -> unit
+    = "caml_sys_modify_argv"
+
+  let override_sys_argv new_argv =
+    caml_sys_modify_argv new_argv;
+    Arg.current := 0
+
+  (* Execute a script.  If [name] is "", read the script from stdin. *)
+
+  let run_script ppf name args =
+    override_sys_argv args;
+    Compmisc.init_path ~dir:(Filename.dirname name) ();
+    (* Note: would use [Filename.abspath] here, if we had it. *)
+    (try toplevel_env := Compmisc.initial_env ()
+     with (Env.Error _ | Typetexp.Error _) as exn ->
+       Location.report_exception ppf exn;
+       raise (Compenv.Exit_with_status 2));
+    Sys.interactive := false;
+    run_hooks After_setup;
+    let explicit_name =
+      (* Prevent use_silently from searching in the path. *)
+      if name <> "" && Filename.is_implicit name then
+        Filename.concat Filename.current_dir_name name
+      else name
+    in
+    use_silently ppf explicit_name
+end
+
+module Topmain = struct
+  (**************************************************************************)
+  (*                                                                        *)
+  (*                                 OCaml                                  *)
+  (*                                                                        *)
+  (*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+  (*                                                                        *)
+  (*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+  (*     en Automatique.                                                    *)
+  (*                                                                        *)
+  (*   All rights reserved.  This file is distributed under the terms of    *)
+  (*   the GNU Lesser General Public License version 2.1, with the          *)
+  (*   special exception on linking described in the file LICENSE.          *)
+  (*                                                                        *)
+  (**************************************************************************)
+
+  let usage =
+    "Usage: ocaml <options> <object-files> [script-file [arguments]]\n\
+     options are:"
+
+  let preload_objects = ref []
+
+  (* Position of the first non expanded argument *)
+  let first_nonexpanded_pos = ref 0
+  let current = ref !Arg.current
+  let argv = ref Sys.argv
+
+  (* Test whether the option is part of a responsefile *)
+  let is_expanded pos = pos < !first_nonexpanded_pos
+
+  let expand_position pos len =
+    if pos < !first_nonexpanded_pos then
+      (* Shift the position *)
+      first_nonexpanded_pos := !first_nonexpanded_pos + len
+    else (* New last position *)
+      first_nonexpanded_pos := pos + len + 2
+
+  let prepare ppf =
+    Toploop.set_paths ();
+    try
+      let res =
+        let objects =
+          List.rev (!preload_objects @ !Compenv.first_objfiles)
+        in
+        List.for_all (Topdirs.load_file ppf) objects
+      in
+      Toploop.run_hooks Toploop.Startup;
+      res
+    with x -> (
+      try
+        Location.report_exception ppf x;
+        false
+      with x ->
+        Format.fprintf ppf "Uncaught exception: %s\n"
+          (Printexc.to_string x);
+        false)
+
+  (* If [name] is "", then the "file" is stdin treated as a script file. *)
+  let file_argument name =
+    let ppf = Format.err_formatter in
+    if
+      Filename.check_suffix name ".cmo"
+      || Filename.check_suffix name ".cma"
+    then preload_objects := name :: !preload_objects
+    else if is_expanded !current then (
+      (* Script files are not allowed in expand options because otherwise the
+         check in override arguments may fail since the new argv can be larger
+         than the original argv.
+      *)
+      Printf.eprintf
+        "For implementation reasons, the toplevel does not support \
+         having script files (here %S) inside expanded arguments \
+         passed through the -args{,0} command-line option.\n"
+        name;
+      raise (Compenv.Exit_with_status 2))
+    else
+      let newargs =
+        Array.sub !argv !current (Array.length !argv - !current)
+      in
+      Compenv.readenv ppf Before_link;
+      Compmisc.read_clflags_from_env ();
+      if prepare ppf && Toploop.run_script ppf name newargs then
+        raise (Compenv.Exit_with_status 0)
+      else raise (Compenv.Exit_with_status 2)
+
+  let wrap_expand f s =
+    let start = !current in
+    let arr = f s in
+    expand_position start (Array.length arr);
+    arr
+
+  module Options = Main_args.Make_bytetop_options (struct
+    include Main_args.Default.Topmain
+
+    let _stdin () = file_argument ""
+    let _args = wrap_expand Arg.read_arg
+    let _args0 = wrap_expand Arg.read_arg0
+    let anonymous s = file_argument s
+  end)
+
+  let () =
+    let extra_paths =
+      match Sys.getenv "OCAMLTOP_INCLUDE_PATH" with
+      | exception Not_found -> []
+      | s -> Misc.split_path_contents s
+    in
+    Clflags.include_dirs :=
+      List.rev_append extra_paths !Clflags.include_dirs
+
+  let main () =
+    let ppf = Format.err_formatter in
+    Compenv.readenv ppf Before_args;
+    let list = ref Options.list in
+    (try
+       Arg.parse_and_expand_argv_dynamic current argv list
+         file_argument usage
+     with
+    | Arg.Bad msg ->
+        Printf.eprintf "%s" msg;
+        raise (Compenv.Exit_with_status 2)
+    | Arg.Help msg ->
+        Printf.printf "%s" msg;
+        raise (Compenv.Exit_with_status 0));
+    Compenv.readenv ppf Before_link;
+    Compmisc.read_clflags_from_env ();
+    if not (prepare ppf) then raise (Compenv.Exit_with_status 2);
+    Compmisc.init_path ();
+    Toploop.loop Format.std_formatter
+
+  let main () =
+    match main () with
+    | exception Compenv.Exit_with_status n -> n
+    | () -> 0
+end
+
+let _ =
+  Clflags.dump_typedtree := true;
+  exit (Topmain.main ())

dune-project

@@ -0,0 +1,26 @@
+(lang dune 3.4)
+
+(name typedastsch)
+
+(generate_opam_files true)
+
+(source
+ (github username/reponame))
+
+(authors "Author Name")
+
+(maintainers "Maintainer Name")
+
+(license LICENSE)
+
+(documentation https://url/to/documentation)
+
+(package
+ (name typedastsch)
+ (synopsis "A short synopsis")
+ (description "A longer description")
+ (depends ocaml dune)
+ (tags
+  (topics "to describe" your project)))
+
+; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project

lib/dot_of_tast.ml

@@ -0,0 +1,26 @@
+open Merlin_kernel
+open Merlin_utils
+
+let _ =
+  Logs.set_reporter (Logs_fmt.reporter ());
+  Logs.set_level (Some Debug)
+
+module Log = (val Logs.src_log
+                    (Logs.Src.create "dot_of_tast"
+                       ~doc:"dot_of_tast.ml logger") : Logs.LOG)
+
+let merlin_parse str : unit =
+  let config, _command_args =
+    Mconfig.parse_arguments ~wd:(Sys.getcwd ())
+      ~warning:(fun _ -> ())
+      (List.map snd []) [] Mconfig.initial []
+  in
+  File_id.with_cache @@ fun () ->
+  let source = Msource.make str in
+  let pipeline = Mpipeline.make config source in
+  Mpipeline.with_pipeline pipeline @@ fun () ->
+  Log.info (fun m -> m "merlin_parse...");
+  let typer = Mpipeline.typer_result pipeline in
+  let structure = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
+  Log.info (fun m ->
+      m "Mbrowse.print: %s" (Mbrowse.print () structure))

lib/dot_of_tast.mli

@@ -0,0 +1 @@
+val merlin_parse : string -> unit

lib/dune

@@ -0,0 +1,14 @@
+(library
+ (name dot_of_tast)
+ (libraries
+   logs.fmt
+   fmt
+   merlin-lib.kernel
+   merlin-lib.analysis
+   merlin-lib.ocaml_merlin_specific
+   merlin-lib.ocaml_utils
+   merlin-lib.ocaml_preprocess
+   merlin-lib.ocaml_parsing
+   merlin-lib.ocaml_typing))
+
+

notes.org

@@ -0,0 +1,23 @@
+
+
+
+** current development pattern
+
+[cqc@fynn typedastsch]$ ocaml
+OCaml version 4.14.0
+Enter #help;; for help.
+
+Findlib has been successfully loaded. Additional directives:
+  #require "package";;      to load a package
+  #list;;                   to list the available packages
+  #camlp4o;;                to load camlp4 (standard syntax)
+  #camlp4r;;                to load camlp4 (revised syntax)
+  #predicates "p,q,...";;   to set these predicates
+  Topfind.reset();;         to force that packages will be reloaded
+  #thread;;                 to enable threads
+
+# #use_output "dune top";;
+# Dot_of_tast.merlin_parse "let x = 0;;"
+  ;;
+Exception: Assert_failure ("src/kernel/mocaml.ml", 29, 2).
+# 

typedastsch.opam

@@ -0,0 +1,31 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "A short synopsis"
+description: "A longer description"
+maintainer: ["Maintainer Name"]
+authors: ["Author Name"]
+license: "LICENSE"
+tags: ["topics" "to describe" "your" "project"]
+homepage: "https://github.com/username/reponame"
+doc: "https://url/to/documentation"
+bug-reports: "https://github.com/username/reponame/issues"
+depends: [
+  "ocaml"
+  "dune" {>= "3.4"}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://github.com/username/reponame.git"