├── opam ├── findlib ├── descr └── opam ├── tests ├── test.txt ├── example_core.ml ├── example.ml ├── test_multiple.ml ├── test_inexisting_toploop.ml ├── test_require.ml ├── test_error.ml ├── test_deferred.ml ├── test_warning.ml └── test_basic.ml ├── _opam ├── app ├── app_conf.ml.ab └── app.ml ├── lib ├── oloop_conf.ml.ab ├── oloop_core2.mli ├── oloop_rule.mli ├── oloop_core2.ml ├── oloop_raw_script.mli ├── oloop_raw_script.ml ├── oloop_script.mli ├── oloop_types.mli ├── oloop.mli ├── oloop_outcome.mli ├── oloop_script.ml ├── oloop_outcome.ml ├── oloop_rule.mlp ├── oloop-top.ml ├── oloop.ml ├── oloop_types.mlp └── oloop_ocaml.mlp ├── .merlin ├── oloop.install ├── .travis.yml ├── .gitignore ├── .ocamlinit ├── _tags ├── README.md ├── LICENSE ├── Makefile └── _oasis /opam/findlib: -------------------------------------------------------------------------------- 1 | oloop 2 | -------------------------------------------------------------------------------- /tests/test.txt: -------------------------------------------------------------------------------- 1 | This is only a test. -------------------------------------------------------------------------------- /_opam: -------------------------------------------------------------------------------- 1 | depends: [ 2 | "cppo" { build } 3 | ] 4 | -------------------------------------------------------------------------------- /tests/example_core.ml: -------------------------------------------------------------------------------- 1 | 2 | let l = List.map [1;2] ~f:(fun x -> x + 1) 3 | -------------------------------------------------------------------------------- /opam/descr: -------------------------------------------------------------------------------- 1 | Evaluate code through the OCaml toploop for inclusion in 2 | educational material. 3 | -------------------------------------------------------------------------------- /app/app_conf.ml.ab: -------------------------------------------------------------------------------- 1 | (* Configuration of the app from be build system. -*-tuareg-*- *) 2 | 3 | let version = "$(pkg_version)" 4 | -------------------------------------------------------------------------------- /lib/oloop_conf.ml.ab: -------------------------------------------------------------------------------- 1 | (* Configuration generated at the configure step. -*- tuareg-*- *) 2 | 3 | let bindir = "$bindir" 4 | 5 | let default_toplevel = Filename.concat bindir "oloop-top" 6 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | S app 2 | S lib 3 | B _build/app 4 | B _build/lib 5 | PKG core 6 | PKG core.syntax 7 | PKG sexplib 8 | PKG sexplib.syntax 9 | PKG async 10 | PKG bytes 11 | PKG compiler-libs.toplevel 12 | -------------------------------------------------------------------------------- /oloop.install: -------------------------------------------------------------------------------- 1 | bin: [ 2 | "?_build/app/app.byte" {"oloop"} 3 | "?_build/app/app.native" {"oloop"} 4 | "?_build/lib/oloop-top.byte" {"oloop-top"} 5 | "?_build/lib/oloop-top.native" {"oloop-top"} 6 | ] 7 | -------------------------------------------------------------------------------- /tests/example.ml: -------------------------------------------------------------------------------- 1 | let first = "123" 2 | 3 | let second = "hello" 4 | 5 | (* Part 2.5 *) 6 | 7 | type foo = string 8 | type bar = int 9 | 10 | let baz = 123 11 | 12 | (* Part 3 *) 13 | 14 | let () = 15 | print_endline "first"; 16 | print_endline "second" 17 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: required 3 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh 4 | script: bash -ex .travis-opam.sh 5 | env: 6 | - OCAML_VERSION=latest PACKAGE=oloop 7 | - OCAML_VERSION=4.02 PACKAGE=oloop 8 | - OCAML_VERSION=4.01 PACKAGE=oloop 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /_build 2 | *.bak 3 | /tmp 4 | 5 | /setup.data 6 | /setup.log 7 | /setup.ml 8 | /*.byte 9 | /*.native 10 | /myocamlbuild.ml 11 | 12 | /lib/META 13 | /lib/oloop.mldylib 14 | /lib/oloop.mllib 15 | /lib/oloop_conf.ml 16 | /lib/oloop_ocaml.ml 17 | /lib/oloop_rule.ml 18 | /lib/oloop_types.ml 19 | 20 | /app/app_conf.ml 21 | -------------------------------------------------------------------------------- /.ocamlinit: -------------------------------------------------------------------------------- 1 | let () = 2 | try Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") 3 | with _ -> ();; 4 | 5 | #use "topfind";; 6 | #thread;; 7 | #require "bytes core async compiler-libs.common compiler-libs.bytecomp";; 8 | #directory "_build/lib";; 9 | #load "oloop.cma";; 10 | open Core.Std;; 11 | open Async.Std;; 12 | open Oloop;; 13 | -------------------------------------------------------------------------------- /tests/test_multiple.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Async.Std 3 | open Format 4 | 5 | let f (x:int) : unit Or_error.t Deferred.t = 6 | printf "run %d\n%!" (x+1); 7 | let f t = 8 | Oloop.eval t "2+3" >>| fun _ -> 9 | Ok () in 10 | Oloop.(with_toploop Outcome.merged ~f) 11 | 12 | let main () = 13 | Deferred.Or_error.List.iter ~f (List.init 1100 ~f:Fn.id) 14 | 15 | let () = 16 | ignore(main() >>|? fun _ -> shutdown 0); 17 | never_returns(Scheduler.go()) 18 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # OASIS_STOP 3 | 4 | true: annot, bin_annot, short_paths 5 | true: warn(A-4@8-33-40-41-42-44-45-48) 6 | : thread 7 | true: thread 8 | # oloop_types is used by both the library (which uses Core) and the 9 | # toploop. We do not want the toploop to depend on Core. 10 | : -thread, -package(core_kernel), -package(async), -package(sexplib.syntax) 11 | true: debug 12 | 13 | # The tmp directory contains (local) throwaway code 14 | "tmp": -traverse 15 | "tmp": not_hygienic 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://travis-ci.org/ocaml/oloop.svg?branch=master)](https://travis-ci.org/ocaml/oloop) 2 | 3 | Oloop 4 | ===== 5 | 6 | Oloop is a library that lets you interact with toploops. 7 | 8 | 9 | 10 | 11 | Generated files 12 | --------------- 13 | 14 | The files `oloop.install` and those under the directory `opam` are 15 | generated from `_oasis` using `oasis2opam`. They are present under 16 | version control in order to enable `opam pin` on the Git repository. 17 | You should not modify those files directly. 18 | -------------------------------------------------------------------------------- /tests/test_inexisting_toploop.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Async.Std 3 | open Format 4 | 5 | let main () = 6 | let eval_phrase t = 7 | Oloop.eval_or_error t "let x = 1" >>|? fun e -> 8 | Oloop.Outcome.print std_formatter (Oloop.Outcome.result e) 9 | in 10 | Oloop.with_toploop Oloop.Outcome.separate ~f:eval_phrase 11 | ~prog:"non-existing-toploop" 12 | >>| function 13 | | Result.Ok() -> shutdown 0 14 | | Result.Error e -> 15 | eprintf "Error: %s\n" (Error.to_string_hum e); 16 | shutdown 1 17 | 18 | 19 | let () = 20 | ignore(main()); 21 | never_returns(Scheduler.go()) 22 | 23 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Anil Madhavapeddy 2 | Copyright (c) 2015, Christophe Troestler 3 | Copyright (c) 2015, Ashish Agarwal 4 | 5 | Permission to use, copy, modify, and/or distribute this software for 6 | any purpose with or without fee is hereby granted, provided that the 7 | above copyright notice and this permission notice appear in all 8 | copies. 9 | 10 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL 11 | WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED 12 | WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE 13 | AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 14 | DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 15 | PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 16 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 17 | PERFORMANCE OF THIS SOFTWARE. 18 | -------------------------------------------------------------------------------- /lib/oloop_core2.mli: -------------------------------------------------------------------------------- 1 | (** Core extensions. After `open Core.Std`, can do `open Oloop_core2` 2 | to extend some modules in Core.Std. *) 3 | open Core_kernel.Std 4 | 5 | module Result : sig 6 | include module type of Result 7 | with type ('a,'b) t = ('a,'b) Result.t 8 | 9 | module List : sig 10 | type ('a, 'b) monad = ('a, 'b) t 11 | type 'a t = 'a list 12 | 13 | val map 14 | : 'a list 15 | -> f:('a -> ('b, 'err) monad) 16 | -> ('b t, 'err) monad 17 | 18 | val mapi 19 | : 'a t 20 | -> f:(int -> 'a -> ('b, 'err) monad) 21 | -> ('b t, 'err) monad 22 | 23 | val fold 24 | : 'a t 25 | -> init:'b 26 | -> f:('b -> 'a -> ('b, 'err) monad) 27 | -> ('b, 'err) monad 28 | 29 | val foldi 30 | : 'a t 31 | -> init:'b 32 | -> f:(int -> 'b -> 'a -> ('b, 'err) monad) 33 | -> ('b, 'err) monad 34 | 35 | end 36 | end 37 | -------------------------------------------------------------------------------- /lib/oloop_rule.mli: -------------------------------------------------------------------------------- 1 | (** Rules to rewrite values. *) 2 | 3 | type t = { 4 | required_values : Longident.t list; 5 | (** Values that must exist and be persistent for the rule to 6 | apply. *) 7 | 8 | rewrite : Location.t -> Parsetree.expression -> Parsetree.expression; 9 | (** The rewrite function. *) 10 | 11 | mutable enabled : bool; 12 | (** Default state. *) 13 | } 14 | 15 | val add : Longident.t -> t -> unit 16 | (** [add lid r] add a rewrite rule, [lid] is the identifier of the 17 | type constructor. *) 18 | 19 | val async : Longident.t 20 | (** Key associated to the Async Deferred.t rule. *) 21 | 22 | val lwt : Longident.t 23 | (** Key associated to the Lwt.t rule. *) 24 | 25 | val enable : Longident.t -> unit 26 | val disable : Longident.t -> unit 27 | 28 | val rewrite : Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase 29 | (** [rewrite phrase] return a phrase modified using to the active 30 | rules. *) 31 | -------------------------------------------------------------------------------- /tests/test_require.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Async.Std 3 | open Format 4 | 5 | let eval t phrase = 6 | printf "# %s;;@\n%!" phrase; 7 | Oloop.eval_or_error t phrase >>=? fun e -> 8 | Oloop.Outcome.print std_formatter (Oloop.Outcome.result e); 9 | if Oloop.Outcome.stdout e <> "" then 10 | printf "OUT: %s\n" (Oloop.Outcome.stdout e); 11 | if Oloop.Outcome.stderr e <> "" then 12 | printf "ERR: %s\n" (Oloop.Outcome.stderr e); 13 | return(Result.Ok()) 14 | 15 | let main () = 16 | let eval_phrases t = 17 | eval t "#use \"topfind\"" >>=? fun () -> 18 | eval t "#thread" >>=? fun () -> 19 | eval t "#require \"lacaml\"" >>=? fun () -> 20 | eval t "open Lacaml.D\n \ 21 | let x = Vec.make0 3" 22 | in 23 | Oloop.with_toploop Oloop.Outcome.separate ~f:eval_phrases 24 | (* ~silent_directives:() *) 25 | 26 | let () = 27 | ignore(main() >>| function 28 | | Result.Ok () -> shutdown 0 29 | | Result.Error e -> eprintf "%s\n%!" (Error.to_string_hum e); 30 | shutdown 1); 31 | never_returns(Scheduler.go()) 32 | -------------------------------------------------------------------------------- /opam/opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "oloop" 3 | version: "dev" 4 | maintainer: "Ashish Agarwal " 5 | authors: [ "Ashish Agarwal" 6 | "Christophe Troestler" ] 7 | license: "ISC" 8 | homepage: "https://github.com/agarwal/oloop" 9 | dev-repo: "https://github.com/agarwal/oloop.git" 10 | bug-reports: "https://github.com/agarwal/oloop/issues" 11 | build: [ 12 | ["oasis" "setup"] 13 | ["ocaml" "setup.ml" "-configure" "--prefix" prefix] 14 | ["ocaml" "setup.ml" "-build"] 15 | ] 16 | install: ["ocaml" "setup.ml" "-install"] 17 | remove: [ 18 | ["ocamlfind" "remove" "oloop"] 19 | ] 20 | build-test: [ 21 | ["oasis" "setup"] 22 | ["ocaml" "setup.ml" "-configure" "--enable-tests"] 23 | ["ocaml" "setup.ml" "-build"] 24 | ["ocaml" "setup.ml" "-test"] 25 | ] 26 | build-doc: [ "ocaml" "setup.ml" "-doc" ] 27 | depends: [ 28 | "async" 29 | "base-bytes" 30 | "base-unix" 31 | "core_kernel" 32 | "oasis" {build & >= "0.4"} 33 | "ocamlfind" {build & >= "1.5"} 34 | "sexplib" 35 | # Included from _opam file 36 | "cppo" { build } 37 | ] 38 | available: [ (ocaml-version >= "4.01.0") & (ocaml-version < "4.02.2") ] 39 | -------------------------------------------------------------------------------- /tests/test_error.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel.Std 2 | open Async.Std 3 | 4 | let phrases = [ 5 | "1 +"; 6 | "1 +. 1."; 7 | "type t = 'a"; 8 | "let rec loop() = 1 + loop() in loop()"; 9 | ] 10 | 11 | 12 | let eval_phrases t = 13 | Deferred.Or_error.List.iter 14 | phrases 15 | ~f:(fun phrase -> 16 | Format.printf "# %s;;@\n%!" phrase; 17 | Oloop.eval t phrase >>| function 18 | | `Eval e -> 19 | Oloop.Outcome.print Format.std_formatter (Oloop.Outcome.result e); 20 | Format.printf "@?"; 21 | Ok() 22 | | `Uneval(e, msg) -> 23 | (match Oloop.Outcome.location_of_uneval e with 24 | | Some l -> Location.print Format.std_formatter l 25 | | None -> ()); 26 | Format.printf "%s" msg; 27 | Oloop.Outcome.report_uneval Format.std_formatter e; 28 | Ok() 29 | ) 30 | 31 | let () = 32 | ignore(Oloop.with_toploop Oloop.Outcome.merged ~f:eval_phrases 33 | >>| function 34 | | Ok _ -> shutdown 0 35 | | Error e -> eprintf "%s\n%!" (Error.to_string_hum e); 36 | shutdown 1); 37 | never_returns(Scheduler.go()) 38 | -------------------------------------------------------------------------------- /lib/oloop_core2.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel.Std 2 | 3 | module Result = struct 4 | include Result 5 | 6 | module List = struct 7 | type ('a, 'b) monad = ('a, 'b) t 8 | type 'a t = 'a list 9 | 10 | let mapi (type error) l ~f = 11 | let module M = struct 12 | exception E of error 13 | let the_fun () = 14 | let run () = 15 | List.mapi l ~f:(fun i x -> 16 | match f i x with 17 | | Ok o -> o 18 | | Error e -> raise (E e)) 19 | in 20 | try Ok (run ()) 21 | with 22 | | E e -> Error e 23 | end in 24 | M.the_fun () 25 | 26 | let map l ~f = 27 | mapi l ~f:(fun _ x -> f x) 28 | 29 | let foldi (type error) l ~init ~f = 30 | let module M = struct 31 | exception E of error 32 | let helper () = 33 | List.foldi l ~init ~f:(fun i accum x -> 34 | match f i accum x with 35 | | Ok x -> x 36 | | Error e -> raise (E e) 37 | ) 38 | end in 39 | try Ok (M.helper ()) 40 | with M.E e -> Error e 41 | 42 | let fold l ~init ~f = 43 | foldi l ~init ~f:(fun _ accum y -> f accum y) 44 | 45 | end 46 | end 47 | -------------------------------------------------------------------------------- /tests/test_deferred.ml: -------------------------------------------------------------------------------- 1 | (* Test the quivalent to Utop behavior for Deferred.t values: evaluate 2 | them automatically. *) 3 | 4 | open Core_kernel.Std 5 | open Async.Std 6 | 7 | let phrases = [ 8 | "#use \"topfind\""; 9 | "#thread"; 10 | "#require \"core\""; 11 | "#require \"async\""; 12 | "open Core.Std"; 13 | "open Async.Std"; 14 | 15 | "Reader.file_contents"; 16 | "let contents = Reader.file_contents \"tests/test.txt\""; 17 | "Deferred.peek contents"; 18 | "contents"; 19 | "Deferred.peek contents"; 20 | ] 21 | 22 | 23 | let eval_phrases t = 24 | Deferred.Or_error.List.iter 25 | phrases 26 | ~f:(fun phrase -> 27 | Format.printf "# %s;;%!" phrase; 28 | Oloop.eval_or_error t phrase >>|? fun e -> 29 | Format.printf "@\n"; 30 | Oloop.Outcome.print Format.std_formatter (Oloop.Outcome.result e); 31 | Format.printf "@?"; 32 | ) 33 | 34 | let () = 35 | ignore(Oloop.with_toploop Oloop.Outcome.separate ~f:eval_phrases 36 | ~silent_directives:() 37 | ~determine_deferred:() 38 | >>| function 39 | | Ok _ -> shutdown 0 40 | | Error e -> eprintf "%s\n%!" (Error.to_string_hum e); 41 | shutdown 1); 42 | never_returns(Scheduler.go()) 43 | -------------------------------------------------------------------------------- /tests/test_warning.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel.Std 2 | open Async.Std 3 | 4 | let phrases = [ 5 | "let f ?(x=1) = x"; 6 | "let g ?(x=1) = x"; 7 | "let f ?(x=1) = \"\\e\" "; 8 | "let h = 9 | Printf.eprintf \"Hello\"; 10 | fun ?(x=1) -> x"; 11 | "let rec even n = match n with 12 | | 0 -> true 13 | | x -> odd (x-1)"; 14 | ] 15 | 16 | let eval_phrases t = 17 | Deferred.Or_error.List.iter 18 | phrases 19 | ~f:(fun phrase -> 20 | Format.printf "# %s;;@\n%!" phrase; 21 | Oloop.eval t phrase >>| function 22 | | `Eval e -> 23 | Oloop.Outcome.print Format.std_formatter (Oloop.Outcome.result e); 24 | Format.printf "@?"; 25 | Format.printf "OUT: %S\nERR: %S\n%!" 26 | (Oloop.Outcome.stdout e) 27 | (Oloop.Outcome.stderr e); 28 | Ok() 29 | | `Uneval(e, msg) -> 30 | Format.printf "%s" msg; 31 | (match Oloop.Outcome.location_of_uneval e with 32 | | Some l -> Location.print Format.std_formatter l 33 | | None -> ()); 34 | Oloop.Outcome.report_uneval Format.std_formatter e; 35 | Ok() 36 | ) 37 | 38 | let () = 39 | ignore(Oloop.with_toploop Oloop.Outcome.separate ~f:eval_phrases 40 | ~msg_with_location:() 41 | >>| function 42 | | Ok _ -> shutdown 0 43 | | Error e -> eprintf "%s\n%!" (Error.to_string_hum e); 44 | shutdown 1); 45 | never_returns(Scheduler.go()) 46 | -------------------------------------------------------------------------------- /tests/test_basic.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Async.Std 3 | open Format 4 | 5 | let eval t phrase = 6 | printf "phrase: %S\n%!" phrase; 7 | Oloop.eval t phrase >>| function 8 | | `Eval e -> 9 | let b = Buffer.create 1024 in 10 | Oloop.Outcome.print (formatter_of_buffer b) (Oloop.Outcome.result e); 11 | printf "OUTCOME: [%s]\n%!" (Buffer.contents b); 12 | printf "OUT: %S\nERR: %S\n%!" (Oloop.Outcome.stdout e) 13 | (Oloop.Outcome.stderr e) 14 | (* printf "OUT+ERR: %S\n" (Oloop.Output.stdout o) *) 15 | | `Uneval(e, msg) -> 16 | printf "ERROR: {|%s|}\n" msg; 17 | (match Oloop.Outcome.location_of_uneval e with 18 | | Some l -> printf "LOCATION: "; 19 | Location.print_loc std_formatter l; 20 | printf "\n" 21 | | None -> ()) 22 | 23 | 24 | let main () = 25 | let phrase1 = "open Printf\n\ 26 | let f x = x + 1\n\ 27 | let () = printf \"Hello\n\"" 28 | and phrase2 = "let () = eprintf \"err\n%!\"; \n\ 29 | printf \"out\n%!\";\n\ 30 | eprintf \"err2\n%!\"; \n\ 31 | printf \"out2\n%!\"\n\ 32 | let x = 1." in 33 | Oloop.create Oloop.Outcome.separate >>= function 34 | (* Oloop.create Oloop.Output.merged >>= function *) 35 | | Result.Error e -> 36 | eprintf "%s\n" (Error.to_string_hum e); 37 | return(shutdown 1) 38 | | Result.Ok t -> 39 | eval t phrase1 >>= fun () -> 40 | eval t phrase2 >>= fun () -> 41 | Oloop.close t >>| fun () -> 42 | shutdown 0 43 | 44 | let () = 45 | ignore(main()); 46 | never_returns(Scheduler.go()) 47 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PKGNAME = $(shell oasis query name) 2 | PKGVERSION = $(shell oasis query version) 3 | PKG_TARBALL = $(PKGNAME)-$(PKGVERSION).tar.gz 4 | 5 | DISTFILES = README.md _oasis _tags Makefile \ 6 | $(wildcard $(addprefix lib/, *.ml *.mli)) 7 | 8 | OPAM_FILES = oloop.install $(addprefix opam/, descr findlib opam) 9 | 10 | all byte native: configure $(OPAM_FILES) 11 | ocaml setup.ml -build 12 | 13 | configure: setup.data 14 | setup.data: setup.ml 15 | ocaml $< -configure --enable-tests 16 | # Use the local executable oloop-top in order to enable tests 17 | # without installing the library: 18 | echo "let default_toplevel = \"./oloop-top.byte\"" \ 19 | >> lib/oloop_conf.ml 20 | 21 | setup.ml: _oasis 22 | oasis setup -setup-update dynamic 23 | -touch $@ 24 | 25 | test doc install uninstall reinstall: all 26 | ocaml setup.ml -$@ 27 | 28 | opam $(OPAM_FILES): _oasis 29 | oasis2opam --local 30 | 31 | tar: $(DISTFILES) 32 | mkdir $(PKGNAME)-$(PKGVERSION) 33 | cp --parents -r $(DISTFILES) $(PKGNAME)-$(PKGVERSION)/ 34 | # Create a setup.ml independent of oasis 35 | cd $(PKGNAME)-$(PKGVERSION) && oasis setup 36 | tar -zcvf $(PKG_TARBALL) $(PKGNAME)-$(PKGVERSION) 37 | $(RM) -rf $(PKGNAME)-$(PKGVERSION) 38 | 39 | clean: 40 | rm -rf \ 41 | _build *.bak *.byte *.native \ 42 | setup.data setup.log setup.ml \ 43 | lib/META lib/oloop.mldylib lib/oloop.mllib \ 44 | lib/oloop_conf.ml lib/oloop_ocaml.ml \ 45 | lib/oloop_rule.ml lib/oloop_types.ml \ 46 | app/app_conf.ml \ 47 | $(PKG_TARBALL) 48 | 49 | 50 | .PHONY: all byte native configure doc test install uninstall reinstall \ 51 | opam clean tar 52 | -------------------------------------------------------------------------------- /lib/oloop_raw_script.mli: -------------------------------------------------------------------------------- 1 | (** Raw scripts are not meant to be evaluated. They consist of a 2 | sequence of alternating input phrases and the corresponding 3 | output. This is useful to represent content in some customized way 4 | that auto-evaluation won't work for. For example: 5 | 6 | {v 7 | # module Make(String : module type of String) = struct ... end;; 8 | module Make : 9 | functor 10 | (String : ...) -> 11 | sig ... end 12 | v} 13 | 14 | We have ellided code in the input phrase and output. This could be 15 | useful to include in educational material, where the accompanying 16 | text mentions that some details are ellided. However, there would 17 | be no systematic way to send the input to OCaml, nor to express 18 | which part of the output should be ellided. Writing out the full 19 | code manually is the best option. 20 | 21 | All we provide here is a simple parser for code in the above 22 | format. A '#' character indicates the start of an input phrase and 23 | a double semicolon indicates its end. Text following a double 24 | semicolon is the output, up until the next '#' character or the 25 | end of input. Unlike [Outcome]s, the output is not split into 26 | OCaml's out phrase vs content printed by evaluating the input. 27 | 28 | The parser is not too smart, e.g. a double semicolon should be the 29 | last item on a line or you will get unexpected results. The idea 30 | is to support content that is copy/paste'd from toplevel output 31 | and then modified manually. 32 | 33 | Unlike the [Scripts] module, there is no notion of [parts], 34 | although that wouldn't be difficult to add. 35 | *) 36 | open Core.Std 37 | open Async.Std 38 | 39 | type item = { 40 | input : string; 41 | output : string; 42 | } 43 | 44 | type t = item list 45 | 46 | val of_file : string -> t Or_error.t Deferred.t 47 | (** Parse a file. *) 48 | 49 | val of_string : filename:string -> string -> t Or_error.t 50 | (** Parse a string. The [filename] is only for error messages. *) 51 | -------------------------------------------------------------------------------- /lib/oloop_raw_script.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Oloop_core2 3 | open Async.Std 4 | 5 | type item = { 6 | input : string; 7 | output : string; 8 | } 9 | 10 | type t = item list 11 | 12 | (** List of lines is in reverse order. The [output] must be empty if 13 | the [input] is, i.e. you cannot have output without input. *) 14 | type partial_item = { 15 | input : string list; 16 | output : string list; 17 | } 18 | 19 | (** [complete x items] assumes we are done parsing [x], so completes 20 | it by converting it to an [item]. It then adds the item to 21 | [items]. Note the items are kept in reverse order. *) 22 | let complete (x:partial_item) (items : item list) : item list = 23 | let f lines = List.rev lines |> String.concat ~sep:"\n" in 24 | if x.input = [] then (* partial item is empty *) 25 | items 26 | else 27 | {input = f x.input; output = f x.output}::items 28 | 29 | let of_string ~filename content = 30 | let open Result.Monad_infix in 31 | String.split content ~on:'\n' |> 32 | List.filter ~f:(function "" -> false | _ -> true) |> 33 | Result.List.fold 34 | ~init:(`Parsing_input, {input=[];output=[]}, []) 35 | ~f:(fun (state, curr_item, completed_items) line -> 36 | match 37 | String.is_prefix line ~prefix:"# ", 38 | String.is_suffix (String.rstrip line) ~suffix:";;", 39 | state 40 | with 41 | | true,true,_ -> 42 | Ok ( 43 | `Parsing_output, 44 | {input=[line]; output=[]}, 45 | (complete curr_item completed_items) 46 | ) 47 | | true,false,_ -> 48 | Ok ( 49 | `Parsing_input, 50 | {input=[line];output=[]}, 51 | (complete curr_item completed_items) 52 | ) 53 | | false,true,`Parsing_input -> ( 54 | assert (curr_item.output = []); 55 | Ok ( 56 | `Parsing_output, 57 | {curr_item with input=line::curr_item.input}, 58 | completed_items 59 | ) 60 | ) 61 | | false,true,`Parsing_output -> 62 | error "unexpected double semicolon while parsing output" 63 | filename sexp_of_string 64 | | false,false,`Parsing_input -> 65 | Ok ( 66 | `Parsing_input, 67 | {curr_item with input=line::curr_item.input}, 68 | completed_items 69 | ) 70 | | false,false,`Parsing_output -> 71 | Ok ( 72 | `Parsing_output, 73 | {curr_item with output=line::curr_item.output}, 74 | completed_items 75 | ) 76 | ) 77 | >>| fun (_, curr_item, completed_items) -> 78 | complete curr_item completed_items |> 79 | List.rev 80 | 81 | let of_file filename = 82 | Reader.file_contents filename 83 | >>| of_string ~filename 84 | -------------------------------------------------------------------------------- /app/app.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Async.Std 3 | open Oloop 4 | 5 | let bool_to_unit = function true -> Some () | false -> None 6 | 7 | let main = Command.async 8 | ~summary:"evaluate code through the OCaml toploop" 9 | Command.Spec.( 10 | empty 11 | +> map ~f:(function [] -> None | x -> Some x) 12 | (flag "-I" (listed file) 13 | ~doc:" Add to the list of include directories") 14 | +> flag "-init" (optional file) 15 | ~doc:" Load instead of default init file" 16 | +> map ~f:bool_to_unit 17 | (flag "-noinit" no_arg ~doc:" Do not load any init file") 18 | +> map ~f:bool_to_unit 19 | (flag "-no-app-funct" no_arg ~doc:" Deactivate applicative functors") 20 | +> map ~f:bool_to_unit 21 | (flag "-principal" no_arg ~doc:" Check principality of type inference") 22 | +> map ~f:bool_to_unit 23 | (flag "-rectypes" no_arg ~doc:" Allow arbitrary recursive types") 24 | +> map ~f:bool_to_unit 25 | (flag "-short-paths" no_arg ~doc:" Shorten paths in types") 26 | +> map ~f:bool_to_unit 27 | (flag "-strict-sequence" no_arg 28 | ~doc:" Left-hand part of a sequence must have type unit") 29 | +> map ~f:bool_to_unit 30 | (flag "-thread" no_arg 31 | ~doc:" Generate code that supports the system threads library") 32 | +> flag "-prog" (optional string) 33 | ~doc:" Full to specially customized toploop" 34 | +> flag "-working-dir" (optional string) 35 | ~doc:" Switch to before running SCRIPT" 36 | +> map ~f:bool_to_unit 37 | (flag "-msg-with-location" no_arg 38 | ~doc:" Add the source location to error messages") 39 | +> map ~f:bool_to_unit 40 | (flag "-silent-directives" no_arg 41 | ~doc:" Make all toploop directives return an empty structure") 42 | +> map ~f:bool_to_unit 43 | (flag "-determine-deferred" no_arg 44 | ~doc:" Determine anonymous Deferred.t values (as Utop does)") 45 | +> map ~f:bool_to_unit 46 | (flag "-determine-lwt" no_arg 47 | ~doc:" Determine anonymous Lwt.t values (as Utop does)") 48 | +> anon ("script" %: file) 49 | ) 50 | (fun include_dirs init noinit no_app_functors principal rectypes 51 | short_paths strict_sequence thread 52 | prog working_dir msg_with_location silent_directives 53 | determine_deferred determine_lwt 54 | file () -> 55 | Script.of_file file 56 | >>=? eval_script ?include_dirs ?init ?noinit ?no_app_functors 57 | ?principal ?rectypes 58 | ?short_paths ?strict_sequence ?thread 59 | ?prog ?working_dir ?msg_with_location ?silent_directives 60 | ?determine_deferred ?determine_lwt 61 | >>|? Script.Evaluated.to_text 62 | >>|? print_endline 63 | >>| function 64 | | Ok () -> () 65 | | Error e -> 66 | eprintf "%s\n" (Error.to_string_hum e) 67 | ) 68 | 69 | let () = 70 | try Command.run ~version:App_conf.version main 71 | with e -> eprintf "%s\n" (Exn.to_string e) 72 | -------------------------------------------------------------------------------- /lib/oloop_script.mli: -------------------------------------------------------------------------------- 1 | (** A toplevel script. Conceptually the same as a script accepted by 2 | the OCaml toplevel, so toplevel directives are 3 | allowed. Differences are: 4 | 5 | - There is no requirement that the script be syntactically valid 6 | or well typed. You may well be using Oloop to demonstrate a syntax 7 | or type error. OCaml returning an error is a valid result from 8 | Oloop's perspective. 9 | 10 | - We detect comments in the form {v (* part X *) v}, allowing to 11 | split a file into multiple parts. The beginning of the file is 12 | part 0 by default, and you must not explicitly write {v (* part 0 13 | *) v}. Part numbers must be in order and are treated as floats to 14 | allow easily adding parts between existing parts. 15 | 16 | - Our parser is not as smart as the one in the compiler. We 17 | require phrases to be terminated by double semicolons, except for 18 | the last phrase in each part. This is also deliberate due to the 19 | fact that we want to simulate what is done interactively in the 20 | toplevel, as the next point explains. 21 | 22 | - Our notion of phrase is not identical to the compiler's 23 | [toplevel_phrase]. In Oloop, [type t = int type u = string;;] is a 24 | single phrase while the compiler parses this as 2 25 | [toplevel_phrase]s. Our goal in defining a single phrase is to let 26 | you control when output is printed, just as you can when 27 | interactively entering text in the toplevel. Providing [type t = 28 | int;; type u = string;;] will cause Oloop to evaluate [type t = 29 | int], print the toplevel's output, evaluate [type u = string], and 30 | print the toplevel's result. In contrast, [type t = int type u = 31 | string;;] will cause both type declarations to be evaluated, and 32 | then print out the result once. 33 | *) 34 | open Core.Std 35 | open Async.Std 36 | 37 | (** A single part consists of a part number and its content. Almost 38 | surely you want to call [phrases_of_string] on the 39 | content. However, we provide the plain content here because you 40 | may also want to display exactly what was input. *) 41 | type part = { 42 | number : float; 43 | content : string; 44 | } 45 | 46 | (** A full script is a sequence of parts, guaranteed to be in order by 47 | part number. *) 48 | type t = private part list 49 | 50 | (** Parse given file. *) 51 | val of_file : string -> t Or_error.t Deferred.t 52 | 53 | (** Parse given file contents. The [filename] is only for error 54 | messages. *) 55 | val of_string : filename:string -> string -> t Or_error.t 56 | 57 | (** Split string into phrases, which are assumed to be terminated by a 58 | double semicolon at the end of a line. It is okay for the last 59 | phrase to not end with a double semicolon. *) 60 | val phrases_of_string : string -> string list 61 | 62 | val nth : t -> float -> part option 63 | 64 | 65 | (** Evaluated scripts. *) 66 | module Evaluated : sig 67 | 68 | (** A phrase and its outcome. *) 69 | type phrase = { 70 | phrase : string; 71 | outcome : Oloop_outcome.merged Oloop_outcome.t; 72 | } 73 | 74 | (** A part and all of its evaluated phrases. *) 75 | type part = { 76 | number : float; 77 | content : string; 78 | phrases : phrase list; 79 | } 80 | 81 | type t = part list 82 | 83 | val nth : t -> float -> part option 84 | 85 | val phrases_to_text : phrase list -> string 86 | val to_text : t -> string 87 | 88 | end 89 | -------------------------------------------------------------------------------- /lib/oloop_types.mli: -------------------------------------------------------------------------------- 1 | (** Module shared between Oloop and the toploop program oloop-top to 2 | ensure type communication. *) 3 | 4 | (** 5 | * Library → toploop 6 | *) 7 | 8 | type top_input = 9 | | Phrase of string 10 | | Init of string (** [""] if the default .ocamlinit must be sought. *) 11 | 12 | val read : in_channel -> top_input 13 | 14 | (** 15 | * Toploop → library 16 | *) 17 | 18 | type serializable_out_value 19 | (** Type equivalent to [Outcometree.out_value] except that it is 20 | serializable. *) 21 | 22 | (** Type equivalent to [Outcometree.out_phrase] except that [out_value] 23 | is replaced by the above serializable version. 24 | [Exception_string] is used in case the exception cannot be 25 | serialized (because of the values it carries) and is then 26 | converted to a string. 27 | [Exception_Stack_overflow] is used so that [Stack_overflow] is 28 | preserved across serialization (so one can catch it with the 29 | standard exception). *) 30 | type serializable_out_phrase = 31 | | Eval of serializable_out_value * Outcometree.out_type 32 | | Signature of (Outcometree.out_sig_item * serializable_out_value option) list 33 | | Exception of (exn * serializable_out_value) 34 | | Exception_string of (string * serializable_out_value) 35 | | Exception_Stack_overflow of serializable_out_value 36 | 37 | val empty : serializable_out_phrase 38 | (** Out phrase that indicates that no particular value is returned by 39 | the toploop. *) 40 | 41 | val of_outcometree_phrase : Outcometree.out_phrase -> serializable_out_phrase 42 | (** Transform the usual [Outcometree.out_phrase] to a serializable 43 | version. *) 44 | 45 | val to_outcometree_value : serializable_out_value -> Outcometree.out_value 46 | 47 | val to_outcometree_sig : 48 | Outcometree.out_sig_item * serializable_out_value option -> 49 | Outcometree.out_sig_item * Outcometree.out_value option 50 | 51 | type serializable_typedecl_error 52 | type serializable_typeclass_error 53 | 54 | (** Enumeration of errors. *) 55 | type serializable_error = 56 | [ `Lexer of Location.t * Lexer.error 57 | | `Syntaxerr of Syntaxerr.error 58 | | `Typedecl of Location.t * serializable_typedecl_error 59 | | `Typetexp of Location.t * Env.summary * Typetexp.error 60 | | `Typecore of Location.t * Env.summary * Typecore.error 61 | | `Typeclass of Location.t * Env.summary * serializable_typeclass_error 62 | | `Symtable of Symtable.error 63 | | `Internal_error of string ] 64 | 65 | val serialize_typedecl_error : Typedecl.error -> serializable_typedecl_error 66 | 67 | val deserialize_typedecl_error : 68 | env_of_summary:(Env.summary -> Env.t) -> serializable_typedecl_error -> 69 | Typedecl.error 70 | 71 | val serialize_typeclass_error : Typeclass.error -> serializable_typeclass_error 72 | 73 | val deserialize_typeclass_error : 74 | env_of_summary:(Env.summary -> Env.t) -> serializable_typeclass_error -> 75 | Typeclass.error 76 | 77 | type out_phrase_or_error = 78 | | Ok of serializable_out_phrase * bool * (Location.t * Warnings.t) list 79 | | Error of (serializable_error * string) 80 | 81 | val send_out_phrase_or_error : out_channel -> out_phrase_or_error -> unit 82 | (** [send_out_phrase_or_error ch p] serialize and send the phrase or 83 | error [p] on the channel [ch]. The channel is flushed after. *) 84 | 85 | val end_output : char 86 | (** Char indicating the end of stdout and stderr for this command. *) 87 | 88 | 89 | (** 90 | * Answer to {!Init} requests 91 | *) 92 | 93 | type init_output = { init_ok: bool; 94 | init_out: string } 95 | 96 | val send_init_outcome : out_channel -> init_output -> unit 97 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | # -*-conf-*- 2 | OASISFormat: 0.4 3 | Name: oloop 4 | Version: dev 5 | Synopsis: Evaluate code through the OCaml toploop for inclusion in 6 | educational material. 7 | #Description: 8 | Authors: Ashish Agarwal, Christophe Troestler 9 | Maintainers: Ashish Agarwal , 10 | Christophe Troestler 11 | License: ISC 12 | Homepage: https://github.com/agarwal/oloop 13 | Plugins: META (0.4), StdFiles (0.4) 14 | OCamlVersion: >= 4.01.0 && < 4.02.2 15 | FilesAB: lib/oloop_conf.ml.ab, app/app_conf.ml.ab 16 | PreBuildCommand: 17 | cppo -V OCAML:${ocaml_version} lib/oloop_ocaml.mlp > lib/oloop_ocaml.ml && 18 | cppo -V OCAML:${ocaml_version} lib/oloop_rule.mlp > lib/oloop_rule.ml && 19 | cppo -V OCAML:${ocaml_version} lib/oloop_types.mlp > lib/oloop_types.ml 20 | 21 | Library "oloop" 22 | Path: lib 23 | BuildTools: ocamlbuild 24 | Modules: Oloop, Oloop_script, Oloop_outcome, Oloop_raw_script 25 | InternalModules: Oloop_ocaml, Oloop_types, Oloop_conf, Oloop_core2 26 | BuildDepends: core_kernel, async, sexplib.syntax, compiler-libs.common, 27 | compiler-libs.bytecomp, bytes 28 | ByteOpt: -thread 29 | NativeOpt: -thread 30 | 31 | Executable "oloop-top" 32 | Path: lib 33 | MainIs: oloop-top.ml 34 | BuildDepends: compiler-libs.toplevel, bytes, dynlink, unix 35 | CompiledObject: byte 36 | BuildTools: ocamlbuild 37 | Install: true 38 | 39 | Executable "oloop" 40 | Path: app 41 | MainIs: app.ml 42 | BuildDepends: oloop, compiler-libs.common 43 | CompiledObject: best 44 | BuildTools: ocamlbuild 45 | Install: true 46 | 47 | # Tests 48 | Executable "basic" 49 | Path: tests 50 | Build$: flag(tests) 51 | MainIs: test_basic.ml 52 | BuildDepends: oloop 53 | CompiledObject: best 54 | BuildTools: ocamlbuild 55 | Install: false 56 | 57 | Executable "require" 58 | Path: tests 59 | Build$: flag(tests) 60 | MainIs: test_require.ml 61 | BuildDepends: oloop 62 | CompiledObject: best 63 | BuildTools: ocamlbuild 64 | Install: false 65 | 66 | Executable "deferred" 67 | Path: tests 68 | Build$: flag(tests) 69 | MainIs: test_deferred.ml 70 | BuildDepends: oloop, async 71 | CompiledObject: best 72 | BuildTools: ocamlbuild 73 | Install: false 74 | 75 | Executable "error" 76 | Path: tests 77 | Build$: flag(tests) 78 | MainIs: test_error.ml 79 | BuildDepends: oloop, async 80 | CompiledObject: best 81 | BuildTools: ocamlbuild 82 | Install: false 83 | 84 | Executable "warning" 85 | Path: tests 86 | Build$: flag(tests) 87 | MainIs: test_warning.ml 88 | BuildDepends: oloop, async 89 | CompiledObject: best 90 | BuildTools: ocamlbuild 91 | Install: false 92 | 93 | Executable "multiple" 94 | Path: tests 95 | Build$: flag(tests) 96 | MainIs: test_multiple.ml 97 | BuildDepends: oloop, async 98 | CompiledObject: best 99 | BuildTools: ocamlbuild 100 | Install: false 101 | 102 | Executable "inexisting_toploop" 103 | Path: tests 104 | Build$: flag(tests) 105 | MainIs: test_inexisting_toploop.ml 106 | BuildDepends: oloop, async 107 | CompiledObject: best 108 | BuildTools: ocamlbuild 109 | Install: false 110 | 111 | 112 | Document API 113 | Title: API reference for Oloop 114 | Type: OCamlbuild (0.4) 115 | InstallDir: $docdir/api 116 | BuildTools: ocamldoc, ocamlbuild 117 | XOCamlbuildPath: . 118 | XOCamlbuildLibraries: oloop 119 | 120 | SourceRepository master 121 | Type: git 122 | Location: https://github.com/agarwal/oloop.git 123 | Browser: https://github.com/agarwal/oloop -------------------------------------------------------------------------------- /lib/oloop.mli: -------------------------------------------------------------------------------- 1 | open Core_kernel.Std 2 | open Async_kernel.Std 3 | 4 | module Script : module type of Oloop_script 5 | 6 | module Raw_script : module type of Oloop_raw_script 7 | 8 | module Outcome : module type of Oloop_outcome 9 | with type separate = Oloop_outcome.separate 10 | with type merged = Oloop_outcome.merged 11 | with type 'a kind = 'a Oloop_outcome.kind 12 | with type 'a eval = 'a Oloop_outcome.eval 13 | 14 | type 'a t 15 | (** A handle to a toploop. *) 16 | 17 | type 'a ocaml_args = 18 | ?include_dirs: string list -> 19 | ?no_app_functors: unit -> 20 | ?principal: unit -> 21 | ?rectypes: unit -> 22 | ?short_paths: unit -> 23 | ?strict_sequence: unit -> 24 | ?thread: unit -> 25 | 'a 26 | 27 | type 'a args = ( 28 | ?prog: string -> 29 | ?working_dir: string -> 30 | ?msg_with_location: unit -> 31 | ?silent_directives: unit -> 32 | ?determine_deferred: unit -> 33 | ?determine_lwt: unit -> 34 | 'a 35 | ) ocaml_args 36 | 37 | val create : ('a Outcome.kind -> 'a t Or_error.t Deferred.t) args 38 | (** Create a new toploop. 39 | 40 | The optional arguments [include_dirs] (-I), [init], 41 | [no_app_functors], [principal], [rectypes], [short_paths] and 42 | [strict_sequence] correspond activate toploop flags. By default, 43 | they are not provided. 44 | 45 | @param msg_with_location if provided, make error messages returned 46 | by {!eval} contain the location of the error. The 47 | location is always accessible using {!location_of_error} which can 48 | be used to highlight the problematic part of the phrase. 49 | 50 | @param silent_directives if set, the toplevel directives (existing 51 | ones or new ones), unless they raise an exception, will return an 52 | empty structure — thus [Oprint.out_phrase] will print nothing — 53 | and their output will be discarded. 54 | 55 | @param determine_deferred Automatically determine anonymous 56 | [Deferred.t] values as Utop does. 57 | 58 | @param determine_lwt Automatically determine anonymous [Lwt.t] 59 | values as Utop does. 60 | 61 | @param prog is full path to the specially customized toploop that 62 | you want to run (if for example it is at an unusual location). *) 63 | 64 | val close : _ t -> unit Deferred.t 65 | (** Terminates the toplevel. *) 66 | 67 | val with_toploop : ( 68 | 'a Outcome.kind -> 69 | f:('a t -> 'b Deferred.Or_error.t) -> 70 | 'b Deferred.Or_error.t 71 | ) args 72 | (** [with_toploop kind f] will run [f], closing the toploop and 73 | freeing its resources whether [f] returns a result or an error. 74 | This is convenient in order use to the bind operator [>>=?] to 75 | chain computations in [f]. *) 76 | 77 | val eval : 'a t -> string -> 'a Outcome.t Deferred.t 78 | (** [eval t phrase] evaluates [phrase] in the toploop [t]. *) 79 | 80 | val eval_or_error : 81 | 'a t -> string -> 'a Outcome.eval Deferred.Or_error.t 82 | (** Same as {!eval} except that the [`Uneval] result is transformed 83 | into an [Error.t] using the function {!Outcome.uneval_to_error}. *) 84 | 85 | val init : ?file: string -> _ t -> unit Deferred.Or_error.t 86 | (** [init t] seek the ".ocamlinit" file and evaluate it. It first 87 | checks whether ".ocamlinit" exists in the current directory and, 88 | if not, it tries to find one in your $HOME directory. 89 | 90 | @param init_file the name (and path, absolute or relative to the 91 | current directory) of the file to evaluate. *) 92 | 93 | val eval_script : 94 | (?init: string -> ?noinit: unit -> 95 | Script.t -> Script.Evaluated.t Or_error.t Deferred.t) args 96 | (** [eval_script sc] evaluate the script [sc] and return the outcome 97 | of each phrase. 98 | 99 | @param init load that file at startup. 100 | @param noinit do not load any file at startup, not even 101 | "$HOME/.ocamlinit". *) 102 | 103 | 104 | (** {2 Miscellaneous} *) 105 | 106 | val phrase_remove_underscore_names : 107 | Outcometree.out_phrase -> Outcometree.out_phrase 108 | 109 | val signatures_remove_underscore_names : 110 | Outcometree.out_sig_item list -> Outcometree.out_sig_item list 111 | 112 | (** Copy of the compiler [Location] module, enriched with conversions 113 | from and to sexp. *) 114 | module Location : sig 115 | include module type of Location with type t = Location.t 116 | 117 | val sexp_of_t : t -> Sexp.t 118 | val t_of_sexp : Sexp.t -> t 119 | end 120 | -------------------------------------------------------------------------------- /lib/oloop_outcome.mli: -------------------------------------------------------------------------------- 1 | (** Outcome of trying to evaluating a phrase. Attempting to evaluate 2 | an arbitrary string as an OCaml phrase can lead to a variety of 3 | outcomes, all of which are captured by [t]: 4 | 5 | - [`Eval (Ophr_eval | Ophr_signature)] - The phrase type checks, 6 | and the OCaml toplevel successfully evaluates it. We provide the 7 | semantic result as an OCaml [out_phrase], and any output that may 8 | have been printed to stdout/stderr. 9 | 10 | - [`Eval Ophr_exception] - The phrase type checks, the OCaml 11 | toplevel evaluates it, but an exception is raised. We provide 12 | information about the exception as an OCaml [out_phrase], and any 13 | output that may have been printed to stdout/stderr. 14 | 15 | - [`Uneval invalid_phrase] - The phrase contains a syntax or type 16 | error, preventing evaluation. We provide compiler constructs 17 | representing the various possible errors, and also a string with a 18 | human readable explanation of the error. 19 | 20 | - [`Uneval `Internal_error] - The phrase could not be evaluated 21 | because the OCaml toploop raised an exception not captured by 22 | the [invalid_phrase] enumeration. 23 | *) 24 | open Core_kernel.Std 25 | 26 | (** Small module to represent exceptions raised by the execution of 27 | toplevel functions (possibly in a "degenerated" form because they 28 | need to be serialized). *) 29 | module Exn : sig 30 | type t 31 | 32 | val to_exn : t -> exn 33 | val to_string : t -> string 34 | val to_error : t -> Error.t 35 | 36 | val of_exn : exn -> t 37 | val of_string : string -> t 38 | end 39 | 40 | (** Close to [Outcometree.out_phrase] except for the exception which 41 | may have been serialized as a string. *) 42 | type out_phrase = 43 | | Eval of Outcometree.out_value * Outcometree.out_type 44 | | Signature of (Outcometree.out_sig_item * Outcometree.out_value option) list 45 | | Exception of (Exn.t * Outcometree.out_value) 46 | 47 | val print : Format.formatter -> out_phrase -> unit 48 | 49 | 50 | type separate (** Stdout and stderr are collected separately. *) 51 | type merged (** Stderr is redirected to stdout. *) 52 | 53 | type 'a kind 54 | (** Specify whether one wants separate stdout and stderr or not. *) 55 | 56 | val separate : separate kind 57 | val merged : merged kind 58 | val kind : _ kind -> [`Separate | `Merged] 59 | 60 | type 'a eval 61 | (** The result of a successful evaluation of a phrase. In particular, 62 | it contains the content printed out to stdout and stderr by the 63 | phrase. The ['a] parameter can be one of the following phantom 64 | types: 65 | 66 | - [separate] - Indicates that stdout and stderr are captured 67 | separately. In this case, you lose information about the relative 68 | order in which content was printed to stdout vs stderr. 69 | 70 | - [merged] - Indicates that stderr is redirected to stdout, and 71 | thus you can only get the stdout. In this case, you lose 72 | information about whether content was printed to stdout or to 73 | stderr. *) 74 | 75 | val result : _ eval -> out_phrase 76 | val stdout : _ eval -> string 77 | val stderr : separate eval -> string 78 | val warnings : _ eval -> (Location.t * Warnings.t) list 79 | 80 | (** List of possible errors when evaluating a phrase. *) 81 | type uneval = [ 82 | | `Lexer of Location.t * Lexer.error 83 | | `Syntaxerr of Syntaxerr.error 84 | | `Typedecl of Location.t * Typedecl.error 85 | | `Typetexp of Location.t * Env.t * Typetexp.error 86 | | `Typecore of Location.t * Env.t * Typecore.error 87 | | `Typeclass of Location.t * Env.t * Typeclass.error 88 | | `Symtable of Symtable.error 89 | | `Internal_error of string 90 | ] with sexp 91 | 92 | (** The outcome of evaluating a phrase. *) 93 | type 'a t = [ 94 | | `Eval of 'a eval 95 | | `Uneval of uneval * string 96 | ] 97 | 98 | val location_of_uneval : uneval -> Location.t option 99 | (** [location_of_uneval e] returns the error location if any is present. *) 100 | 101 | val report_uneval : ?msg_with_location: bool -> 102 | Format.formatter -> uneval -> unit 103 | (** [report_error ppf e] write an error message corresponding to [e] 104 | to the formatter [ppf] just as the toploop would do it. *) 105 | 106 | val uneval_to_error : uneval * string -> Error.t 107 | (** [uneval_to_error(e, msg)] treats [e] as an error, thus making it 108 | meaningful to convert it to an [Error.t]. Depending on your usage 109 | of Oloop, this may or may not be correct. Perhaps you are trying 110 | to demonstrate a syntax error, in which case getting an [uneval] 111 | is not wrong. *) 112 | 113 | 114 | (**/**) 115 | 116 | val make_eval : result: out_phrase -> 117 | stdout: string -> 118 | stderr: string -> 119 | warnings: (Location.t * Warnings.t) list -> 120 | 'a kind -> 'a eval 121 | 122 | val deserialize_to_uneval : Oloop_types.serializable_error -> uneval 123 | -------------------------------------------------------------------------------- /lib/oloop_script.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Oloop_core2 3 | open Async.Std 4 | module Outcome = Oloop_outcome 5 | 6 | type part = { 7 | number : float; 8 | content : string; 9 | } 10 | 11 | type t = part list 12 | 13 | let phrases_of_string s : string list = 14 | let rec loop (phrase,phrases) = function 15 | | [] -> phrase :: phrases 16 | | ""::lines -> 17 | loop (phrase,phrases) lines 18 | | line::lines -> 19 | let accum = 20 | if String.rstrip line |> String.is_suffix ~suffix:";;" then 21 | ([], (line::phrase)::phrases) 22 | else 23 | (line::phrase, phrases) 24 | in 25 | loop accum lines 26 | in 27 | let make_phrase l = String.concat ~sep:"\n" (List.rev l) in 28 | let phrases = loop ([],[]) (String.split_lines s) in 29 | List.rev_map phrases ~f:make_phrase 30 | (* The final phrase might be an empty string, which we do not 31 | consider an error. We simply filter it out. *) 32 | |> List.filter ~f:(fun x -> not (String.for_all x ~f:Char.is_whitespace)) 33 | 34 | (** [line_to_part_num ~filename line] parses the part number from a 35 | line. [None] is returned if the line does not indicate the start 36 | of a new part. [Error] is returned if the line does indicate start 37 | of a new part, but there is an error in the formatting. The 38 | [filename] is only for error messages. *) 39 | let line_to_part_num ~filename line : float option Or_error.t = 40 | let lstripped = String.lstrip line in 41 | if String.is_prefix ~prefix:"(* Part " lstripped 42 | || String.is_prefix ~prefix:"(* part " lstripped then ( 43 | try Ok (Some (Scanf.sscanf lstripped "(* %_s %f *)" ident)) 44 | with _ -> 45 | error "invalid (* part N *) line" 46 | (filename,line) <:sexp_of< string * string >> 47 | ) 48 | else 49 | Ok None 50 | 51 | let of_string ~filename contents = 52 | let open Result.Monad_infix in 53 | String.split ~on:'\n' contents 54 | |> Result.List.fold 55 | ~init:((0., Buffer.create 100), []) 56 | ~f:(fun (curr_part, parts) line -> 57 | line_to_part_num ~filename line >>| function 58 | | Some part_num -> 59 | (part_num, (Buffer.create 100)), curr_part::parts 60 | | None -> 61 | ( 62 | let part_num,buf = curr_part in 63 | Buffer.add_string buf line; 64 | Buffer.add_char buf '\n'; 65 | (part_num,buf), parts 66 | ) 67 | ) 68 | >>= fun (curr_part,parts) -> 69 | let parts = List.rev_map (curr_part::parts) ~f:(fun (number,content) -> 70 | {number; content = Buffer.contents content} ) 71 | in 72 | let part_nums = List.map parts ~f:(fun x -> x.number) in 73 | if List.is_sorted_strictly part_nums ~compare:Float.compare then 74 | Ok parts 75 | else 76 | error "part numbers not strictly increasing" 77 | (filename,part_nums) <:sexp_of< string * float list >> 78 | 79 | let of_file filename = 80 | Reader.file_contents filename 81 | >>| of_string ~filename 82 | 83 | let nth t x = 84 | List.find t ~f:(fun {number;_} -> Float.equal number x) 85 | 86 | 87 | module Evaluated = struct 88 | 89 | type phrase = { 90 | phrase : string; 91 | outcome : Oloop_outcome.merged Oloop_outcome.t; 92 | } 93 | 94 | type part = { 95 | number : float; 96 | content : string; 97 | phrases : phrase list; 98 | } 99 | 100 | type t = part list 101 | 102 | let nth t x = 103 | List.find t ~f:(fun {number;_} -> Float.equal number x) 104 | 105 | let phrases_to_text,to_text = 106 | let phrases_to_text_helper buf phrases = 107 | let fmt = Format.formatter_of_buffer buf in 108 | let add_string x = Buffer.add_string buf x in 109 | let add_stringl x = Buffer.add_string buf x; Buffer.add_char buf '\n' in 110 | List.iter phrases ~f:(fun {phrase; outcome} -> 111 | add_string "# "; add_stringl phrase; 112 | ( 113 | match outcome with 114 | | `Uneval (`Internal_error s, msg) -> ( 115 | add_stringl s; 116 | add_stringl msg; 117 | ) 118 | | `Uneval (x, msg) -> ( 119 | (* add_stringl *) 120 | (* (Outcome.sexp_of_invalid_phrase x |> Sexp.to_string_hum); *) 121 | add_stringl msg; 122 | ) 123 | | `Eval e -> ( 124 | List.iter (Outcome.warnings e) ~f:(fun (loc,warning) -> 125 | Location.print_loc fmt loc; 126 | ignore (Warnings.print fmt warning) 127 | ); 128 | Outcome.print fmt (Outcome.result e); 129 | add_stringl (Outcome.stdout e) 130 | ) 131 | ) 132 | ) 133 | in 134 | let phrases_to_text phrases = 135 | let buf = Buffer.create 2048 in 136 | phrases_to_text_helper buf phrases; 137 | Buffer.contents buf 138 | in 139 | let to_text t = 140 | let buf = Buffer.create 2048 in 141 | List.iter t ~f:(fun {number; content=_; phrases} -> 142 | Buffer.add_string buf "(* part "; 143 | Buffer.add_string buf (Float.to_string_hum number ~strip_zero:true); 144 | Buffer.add_string buf " *)\n"; 145 | phrases_to_text_helper buf phrases; 146 | ); 147 | Buffer.contents buf 148 | in 149 | phrases_to_text, to_text 150 | 151 | end 152 | -------------------------------------------------------------------------------- /lib/oloop_outcome.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel.Std 2 | 3 | module Exn = struct 4 | exception T of string 5 | 6 | type t = Exn of exn 7 | | String of string 8 | 9 | let of_exn e = Exn e 10 | let of_string s = String s 11 | 12 | let to_exn = function Exn e -> e 13 | | String s -> T s 14 | 15 | let to_string = function Exn e -> Core_kernel.Std.Exn.to_string e 16 | | String s -> s 17 | 18 | let to_error = function Exn e -> Error.of_exn e 19 | | String s -> Error.of_string s 20 | end 21 | 22 | type out_phrase = 23 | | Eval of Outcometree.out_value * Outcometree.out_type 24 | | Signature of (Outcometree.out_sig_item * Outcometree.out_value option) list 25 | | Exception of (Exn.t * Outcometree.out_value) 26 | 27 | let print ppf = function 28 | | Eval(v, t) -> !Oprint.out_phrase ppf (Outcometree.Ophr_eval(v,t)) 29 | | Signature l -> !Oprint.out_phrase ppf (Outcometree.Ophr_signature l) 30 | | Exception(Exn.Exn Stack_overflow, _) -> 31 | Format.fprintf 32 | ppf "Stack overflow during evaluation (looping recursion?).@." 33 | | Exception(Exn.Exn e, v) -> 34 | Printf.printf "*** %s ***\n" (Core_kernel.Std.Exn.to_string e); 35 | (* Exceptions [Sys.Break], [Out_of_memory] can be serialized as 36 | exceptions — so fall in this case *) 37 | !Oprint.out_phrase ppf (Outcometree.Ophr_exception(e, v)) 38 | | Exception(Exn.String s, v) -> 39 | (* Based on the compiler Oprint.print_out_exception: *) 40 | (* Format.fprintf ppf "@[Exception:@ %a.@]@." !Oprint.out_value v *) 41 | (* FIXME: However the previous instruction breaks lines of [v] 42 | strangely so we use the string version which has been 43 | generated by the toploop. *) 44 | Format.fprintf ppf "@[Exception:@ %s.@]@." s 45 | 46 | type separate 47 | type merged 48 | (* FIXME: One can imagine a 3rd possibility [interleaved], in which no 49 | information is lost. This would provide a sequence of content in 50 | the order printed out, and tagged as being to stdout or to stderr. 51 | This has not been implemented. *) 52 | 53 | type 'a kind = bool 54 | let separate = false 55 | let merged = true 56 | let kind x = if x then `Merged else `Separate 57 | 58 | type 'a eval = { 59 | result: out_phrase; 60 | stdout: string; 61 | stderr: string; 62 | warnings: (Location.t * Warnings.t) list 63 | } 64 | 65 | let result e = e.result 66 | let stdout t = t.stdout 67 | let stderr t = t.stderr 68 | let warnings e = e.warnings 69 | 70 | let make_eval ~result ~stdout ~stderr ~warnings _ = 71 | { result; stdout; stderr; warnings } 72 | 73 | type uneval = [ 74 | | `Lexer of Oloop_ocaml.Location.t * Oloop_ocaml.Lexer.error 75 | | `Syntaxerr of Oloop_ocaml.Syntaxerr.error 76 | | `Typedecl of Oloop_ocaml.Location.t * Oloop_ocaml.Typedecl.error 77 | | `Typetexp of Oloop_ocaml.Location.t * Oloop_ocaml.Env.t 78 | * Oloop_ocaml.Typetexp.error 79 | | `Typecore of Oloop_ocaml.Location.t * Oloop_ocaml.Env.t 80 | * Oloop_ocaml.Typecore.error 81 | | `Typeclass of Oloop_ocaml.Location.t * Oloop_ocaml.Env.t 82 | * Oloop_ocaml.Typeclass.error 83 | | `Symtable of Oloop_ocaml.Symtable.error 84 | | `Internal_error of string 85 | ] with sexp 86 | 87 | type 'a t = [ 88 | | `Eval of 'a eval 89 | | `Uneval of uneval * string 90 | ] 91 | 92 | let env_of_summary = Oloop_ocaml.Env.of_summary 93 | 94 | let deserialize_to_uneval : Oloop_types.serializable_error -> uneval = 95 | function 96 | | (`Lexer _ | `Syntaxerr _ | `Symtable _ | `Internal_error _) as e -> e 97 | | `Typedecl(loc, e) -> 98 | `Typedecl(loc, Oloop_types.deserialize_typedecl_error 99 | ~env_of_summary e) 100 | | `Typetexp(loc, env, e) -> `Typetexp(loc, env_of_summary env, e) 101 | | `Typecore(loc, env, e) -> `Typecore(loc, env_of_summary env, e) 102 | | `Typeclass(loc, env, e) -> 103 | let e = Oloop_types.deserialize_typeclass_error ~env_of_summary e in 104 | `Typeclass(loc, env_of_summary env, e) 105 | 106 | let location_of_uneval : uneval -> Location.t option = function 107 | | `Lexer(l, _) | `Typedecl(l, _) | `Typetexp(l, _, _) 108 | | `Typecore(l, _, _) | `Typeclass(l, _, _) -> Some l 109 | | `Syntaxerr _ | `Symtable _ | `Internal_error _ -> None 110 | 111 | let report_uneval ?(msg_with_location=false) ppf e = 112 | match e with 113 | | `Internal_error s -> 114 | Format.fprintf ppf "`Internal_error (Oloop): %s" s 115 | | (`Lexer _ | `Syntaxerr _ | `Typedecl _ | `Typetexp _ | `Typecore _ 116 | | `Typeclass _ | `Symtable _) as e -> 117 | (* Do the reverse than the conversion in oloop-top in order to be able 118 | to use the compiler reporting functions. The difference is that 119 | all environments are empty (they cannot be serialized). *) 120 | let exn = match e with 121 | | `Lexer(l, e) -> Lexer.Error(e, l) 122 | | `Syntaxerr e -> Syntaxerr.Error e 123 | | `Typedecl(l, e) -> Typedecl.Error(l, e) 124 | | `Typetexp(l, env, e) -> Typetexp.Error(l, env, e) 125 | | `Typecore(l, env, e) -> Typecore.Error(l, env, e) 126 | | `Typeclass(l, env, e) -> Typeclass.Error(l, env, e) 127 | | `Symtable e -> Symtable.Error e in 128 | if msg_with_location then 129 | Errors.report_error ppf exn 130 | else ( 131 | (* The location of the error is reported because the terminal is 132 | detected as dumb. Remove it "manually". *) 133 | let b = Buffer.create 64 in 134 | let fmt = Format.formatter_of_buffer b in 135 | Errors.report_error fmt exn; 136 | Format.pp_print_flush fmt (); 137 | let len = Buffer.length b in 138 | let loc_present = 139 | Buffer.(len > 3 && nth b 0 = 'C' && nth b 1 = 'h' && nth b 2 = 'a') in 140 | let ofs = 141 | if loc_present then ( 142 | (* Skip the first line. *) 143 | let ofs = ref 0 in 144 | while !ofs < len && Buffer.nth b !ofs <> '\n' do incr ofs done; 145 | !ofs + 1 146 | ) 147 | else 0 in 148 | let err = try Buffer.sub b ofs (len - ofs) 149 | with Invalid_argument _ -> "" in 150 | Format.pp_print_string ppf err 151 | ) 152 | 153 | let uneval_to_error (e, msg) = 154 | match e with 155 | | `Internal_error s -> 156 | Error.tag (Error.of_string s) msg 157 | | e -> 158 | let here = match location_of_uneval e with 159 | | Some loc -> Some loc.Location.loc_start 160 | | None -> None in 161 | Error.create ?here msg e sexp_of_uneval 162 | -------------------------------------------------------------------------------- /lib/oloop_rule.mlp: -------------------------------------------------------------------------------- 1 | (* Toplevel functionality. It is preprocessed because it contains 2 | code dependent on then compiler version. *) 3 | 4 | (* Code taken from UTop_main and adapted to the current project. *) 5 | 6 | type t = { 7 | required_values : Longident.t list; 8 | rewrite : Location.t -> Parsetree.expression -> Parsetree.expression; 9 | mutable enabled : bool; 10 | } 11 | 12 | (* Rewrite rules, indexed by the identifier of the type 13 | constructor. *) 14 | let rewrite_rules : (Longident.t, t) Hashtbl.t = Hashtbl.create 8 15 | 16 | let add key rule = Hashtbl.add rewrite_rules key rule 17 | 18 | let set key v = 19 | try (Hashtbl.find rewrite_rules key).enabled <- v 20 | with Not_found -> () 21 | 22 | let enable key = set key true 23 | let disable key = set key false 24 | 25 | let longident_lwt_main_run = 26 | Longident.Ldot (Longident.Lident "Lwt_main", "run") 27 | 28 | let longident_async_thread_safe_block_on_async_exn = 29 | Longident.parse "Async.Std.Thread_safe.block_on_async_exn" 30 | 31 | let longident_unit = 32 | Longident.Lident "()" 33 | 34 | let with_loc loc str = { 35 | Location.txt = str; 36 | Location.loc = loc; 37 | } 38 | 39 | #if OCAML_VERSION < (4, 02, 0) 40 | (* Wrap into: fun () -> *) 41 | let wrap_unit loc e = 42 | let i = with_loc loc longident_unit in 43 | let p = { 44 | Parsetree.ppat_desc = Parsetree.Ppat_construct (i, None, false); 45 | Parsetree.ppat_loc = loc; 46 | } in 47 | { 48 | Parsetree.pexp_desc = Parsetree.Pexp_function ("", None, [(p, e)]); 49 | Parsetree.pexp_loc = loc; 50 | } 51 | #endif 52 | 53 | #if OCAML_VERSION >= (4, 03, 0) 54 | let nolabel = Asttypes.Nolabel 55 | #else 56 | let nolabel = "" 57 | #endif 58 | 59 | let lwt = Longident.Ldot (Longident.Lident "Lwt", "t") 60 | 61 | let () = 62 | (* Rewrite Lwt.t expressions to Lwt_main.run *) 63 | let rewrite loc e = 64 | #if OCAML_VERSION < (4, 02, 0) 65 | { Parsetree.pexp_desc = 66 | Parsetree.Pexp_apply 67 | ({ Parsetree.pexp_desc = 68 | Parsetree.Pexp_ident (with_loc loc longident_lwt_main_run); 69 | Parsetree.pexp_loc = loc }, 70 | [("", e)]) 71 | ; Parsetree.pexp_loc = loc } 72 | #else 73 | let open Ast_helper in 74 | with_default_loc 75 | loc (fun () -> 76 | Exp.apply (Exp.ident (with_loc loc longident_lwt_main_run)) 77 | [(nolabel, e)] 78 | ) 79 | #endif 80 | in 81 | add lwt { required_values = [longident_lwt_main_run]; 82 | rewrite; 83 | enabled = false } 84 | 85 | let async = Longident.parse "Async_core.Ivar.Deferred.t" 86 | 87 | let () = 88 | let rewrite loc e = 89 | #if OCAML_VERSION < (4, 02, 0) 90 | { Parsetree.pexp_desc = 91 | Parsetree.Pexp_apply 92 | ({ Parsetree.pexp_desc = 93 | Parsetree.Pexp_ident (with_loc loc longident_async_thread_safe_block_on_async_exn); 94 | Parsetree.pexp_loc = loc }, 95 | [("", wrap_unit loc e)]) 96 | ; Parsetree.pexp_loc = loc } 97 | #else 98 | let open Ast_helper in 99 | let punit = Pat.construct (with_loc loc (Longident.Lident "()")) None in 100 | with_default_loc 101 | loc (fun () -> 102 | Exp.apply 103 | (Exp.ident (with_loc loc longident_async_thread_safe_block_on_async_exn)) 104 | [(nolabel, Exp.fun_ nolabel None punit e)] 105 | ) 106 | #endif 107 | in 108 | let rule = { 109 | required_values = [longident_async_thread_safe_block_on_async_exn]; 110 | rewrite; 111 | enabled = false } in 112 | add async rule; 113 | add (Longident.parse "Async_kernel.Ivar.Deferred.t") rule 114 | 115 | (* Convert a path to a long identifier. *) 116 | let rec longident_of_path path = 117 | match path with 118 | | Path.Pident id -> 119 | Longident.Lident (Ident.name id) 120 | | Path.Pdot (path, s, _) -> 121 | Longident.Ldot (longident_of_path path, s) 122 | | Path.Papply (p1, p2) -> 123 | Longident.Lapply (longident_of_path p1, longident_of_path p2) 124 | 125 | (* Returns the rewrite rule associated to a type, if any. *) 126 | let rec rule_of_type typ = 127 | match typ.Types.desc with 128 | | Types.Tlink typ -> 129 | rule_of_type typ 130 | | Types.Tconstr (path, _, _) -> 131 | (match try Some (Env.find_type path !Toploop.toplevel_env) 132 | with Not_found -> None with 133 | | Some { Types.type_kind = Types.Type_abstract; 134 | Types.type_private = Asttypes.Public; 135 | Types.type_manifest = Some typ } -> 136 | rule_of_type typ 137 | | _ -> 138 | try 139 | Some (Hashtbl.find rewrite_rules (longident_of_path path)) 140 | with Not_found -> 141 | None 142 | ) 143 | | _ -> 144 | None 145 | 146 | (* Returns whether the given path is persistent. *) 147 | let rec is_persistent_path = function 148 | | Path.Pident id -> Ident.persistent id 149 | | Path.Pdot (p, _, _) -> is_persistent_path p 150 | | Path.Papply (_, p) -> is_persistent_path p 151 | 152 | (* Check that the given long identifier is present in the environment 153 | and is persistent. *) 154 | let is_persistent_in_env longident = 155 | try is_persistent_path 156 | (fst (Env.lookup_value longident !Toploop.toplevel_env)) 157 | with Not_found -> 158 | false 159 | 160 | #if OCAML_VERSION < (4, 02, 0) 161 | let rewrite_str_item pstr_item tstr_item = 162 | match pstr_item, tstr_item.Typedtree.str_desc with 163 | | ({ Parsetree.pstr_desc = Parsetree.Pstr_eval e; 164 | Parsetree.pstr_loc = loc }, 165 | Typedtree.Tstr_eval { Typedtree.exp_type = typ }) -> 166 | (match rule_of_type typ with 167 | | Some rule -> 168 | if rule.enabled 169 | && List.for_all is_persistent_in_env rule.required_values then 170 | { Parsetree.pstr_desc = Parsetree.Pstr_eval (rule.rewrite loc e); 171 | Parsetree.pstr_loc = loc } 172 | else 173 | pstr_item 174 | | None -> 175 | pstr_item 176 | ) 177 | | _ -> 178 | pstr_item 179 | #else 180 | let rewrite_str_item pstr_item tstr_item = 181 | match pstr_item, tstr_item.Typedtree.str_desc with 182 | | ({ Parsetree.pstr_desc = Parsetree.Pstr_eval (e, _); 183 | Parsetree.pstr_loc = loc }, 184 | Typedtree.Tstr_eval ({ Typedtree.exp_type = typ }, _)) -> 185 | (match rule_of_type typ with 186 | | Some rule -> 187 | if rule.enabled 188 | && List.for_all is_persistent_in_env rule.required_values then 189 | { Parsetree.pstr_desc = 190 | Parsetree.Pstr_eval (rule.rewrite loc e, []); 191 | Parsetree.pstr_loc = loc } 192 | else 193 | pstr_item 194 | | None -> 195 | pstr_item 196 | ) 197 | | _ -> 198 | pstr_item 199 | #endif 200 | ;; 201 | 202 | let no_output = { Format. 203 | out_string = (fun _s _ofs _len -> ()); 204 | out_flush = (fun () -> ()); 205 | out_newline = (fun () -> ()); 206 | out_spaces = (fun _ -> ()) } 207 | 208 | let err_output = Format.pp_get_formatter_out_functions Format.err_formatter () 209 | 210 | let rewrite phrase = match phrase with 211 | | Parsetree.Ptop_def pstr -> 212 | (* The typing may generate warnings that one does *not* want to 213 | display. *) 214 | Format.pp_print_flush Format.err_formatter (); 215 | Format.pp_set_formatter_out_functions Format.err_formatter no_output; 216 | (try 217 | let tstr, _, _ = Typemod.type_structure !Toploop.toplevel_env pstr 218 | Location.none in 219 | Format.pp_set_formatter_out_functions Format.err_formatter err_output; 220 | Parsetree.Ptop_def (List.map2 rewrite_str_item pstr 221 | tstr.Typedtree.str_items) 222 | with _ -> 223 | Format.pp_set_formatter_out_functions Format.err_formatter err_output; 224 | phrase) 225 | | Parsetree.Ptop_dir _ -> 226 | (* Directive *) 227 | phrase 228 | -------------------------------------------------------------------------------- /lib/oloop-top.ml: -------------------------------------------------------------------------------- 1 | (* Toplevel that communicates with the main Oloop module. This 2 | program should depend on the minimal amount of libraries so as to 3 | minimize conflicts when #load'ing modules. *) 4 | 5 | open Oloop_types 6 | module Rule = Oloop_rule 7 | 8 | (* Force the linking of some modules for, say, #load "camlp4o.cma" *) 9 | module S___ = Stream 10 | module Q___ = Queue 11 | module C___ = CamlinternalOO 12 | module D___ = Dynlink 13 | module St__ = StdLabels 14 | module Cp__ = Complex 15 | module Sc__ = Scanf 16 | module Gc__ = Gc 17 | module ML__ = MoreLabels 18 | module CiM_ = CamlinternalMod 19 | module Gl__ = Genlex 20 | module Oo__ = Oo 21 | module So__ = Sort (* Deprecated but used by ocamlfind anyway *) 22 | module Ll__ = ListLabels 23 | module Sl__ = StringLabels 24 | module Al__ = ArrayLabels 25 | module Lz__ = Lazy 26 | 27 | let add_dir_from_env env = 28 | try Topdirs.dir_directory (Sys.getenv env) 29 | with Not_found -> () 30 | 31 | let initialize_toplevel ~redirect_stderr = 32 | Sys.interactive := true; 33 | Toploop.set_paths (); 34 | Toploop.initialize_toplevel_env(); 35 | Toploop.input_name := "//toplevel//"; 36 | Location.input_name := "//toplevel//"; 37 | Toploop.max_printer_steps := 20; 38 | add_dir_from_env "OCAML_TOPLEVEL_PATH"; 39 | add_dir_from_env "CAML_LD_LIBRARY_PATH"; 40 | if redirect_stderr then 41 | Unix.dup2 Unix.stdout Unix.stderr; 42 | (* Add #load *) 43 | let load cma = Topdirs.dir_load Format.str_formatter cma in 44 | Toploop.(Hashtbl.add directive_table "load" (Directive_string load)) 45 | 46 | 47 | (* This special toplevel will not print the result of the evaluation 48 | of phrases but store it to transmit it in its original form in a 49 | special channel. *) 50 | let out_phrase = ref Oloop_types.empty (* dummy *) 51 | let () = 52 | Toploop.print_out_phrase 53 | := fun _fmt phrase -> 54 | out_phrase := Oloop_types.of_outcometree_phrase phrase 55 | 56 | (* let () = *) 57 | (* See also oloop_rule.ml which needs to (locally) turn off this formatter. *) 58 | (* Location.formatter_for_warnings := FIXME *) 59 | 60 | let rec is_prefix_loop pre s i len_pre = 61 | i >= len_pre || (pre.[i] = s.[i] && is_prefix_loop pre s (i + 1) len_pre) 62 | 63 | let is_prefix pre s = 64 | if String.length pre > String.length s then false 65 | else is_prefix_loop pre s 0 (String.length pre) 66 | 67 | let remove_location s = 68 | if is_prefix "Characters " s then ( 69 | let i = String.index s '\n' + 1 in 70 | String.sub s i (String.length s - i) 71 | ) 72 | else s 73 | 74 | let eval ~msg_with_location lexbuf = 75 | try 76 | Location.init lexbuf "//toplevel//"; 77 | let phrase = !Toploop.parse_toplevel_phrase lexbuf in 78 | let phrase = Rule.rewrite phrase in 79 | Env.reset_cache_toplevel (); 80 | ignore(Toploop.execute_phrase true Format.str_formatter phrase); 81 | ignore(Format.flush_str_formatter ()); (* fill [out_phrase] *) 82 | let warnings = [] in (* for future compilers *) 83 | let is_directive = match phrase with 84 | | Parsetree.Ptop_def _ -> false 85 | | Parsetree.Ptop_dir _ -> true in 86 | Ok(!out_phrase, is_directive, warnings) 87 | with 88 | | End_of_file -> exit 0 89 | | e -> 90 | let backtrace_enabled = Printexc.backtrace_status () in 91 | if not backtrace_enabled then Printexc.record_backtrace true; 92 | let msg = try Errors.report_error Format.str_formatter e; 93 | Format.flush_str_formatter () 94 | with _ -> "" in 95 | if not backtrace_enabled then Printexc.record_backtrace false; 96 | let err = match e with 97 | | Lexer.Error(e, l) -> `Lexer(l, e) 98 | | Syntaxerr.Error e -> `Syntaxerr e 99 | | Typedecl.Error(l, e) -> 100 | `Typedecl(l, Oloop_types.serialize_typedecl_error e) 101 | | Typetexp.Error(l, env, e) -> `Typetexp(l, Env.summary env, e) 102 | | Typecore.Error(l, env, e) -> `Typecore(l, Env.summary env, e) 103 | | Typeclass.Error(l, env, e) -> 104 | `Typeclass(l, Env.summary env, 105 | Oloop_types.serialize_typeclass_error e) 106 | | Symtable.Error e -> `Symtable e 107 | (* FIXME: add more *) 108 | | _ -> `Internal_error(Printexc.to_string e) in 109 | let msg = if msg_with_location then msg else remove_location msg in 110 | Error(err, msg) 111 | 112 | let eval_and_send ch ~msg_with_location ~redirect_stderr (phrase: string) = 113 | let outcome = 114 | try eval ~msg_with_location (Lexing.from_string(phrase ^ ";;")) 115 | with e -> Error(`Internal_error(Printexc.to_string e), 116 | "Exception raised during the phrase evaluation") in 117 | (* Sending a special ASCII char to indicate the end of the output 118 | is not 100% robust but the alternative consisting of reading as 119 | much as is available does not work well. *) 120 | if redirect_stderr then ( 121 | (* If stderr is redirected to stdout, we do not want to send the 122 | separating char twice on stdout. Flush both formatters first 123 | to ensure that [end_output] is at the end. *) 124 | Format.pp_print_flush Format.std_formatter (); 125 | Format.pp_print_flush Format.err_formatter (); 126 | Format.pp_print_char Format.std_formatter end_output; 127 | Format.pp_print_flush Format.std_formatter (); 128 | ) 129 | else ( 130 | Format.pp_print_char Format.std_formatter end_output; 131 | Format.pp_print_flush Format.std_formatter (); 132 | Format.pp_print_char Format.err_formatter end_output; 133 | Format.pp_print_flush Format.err_formatter (); 134 | ); 135 | try send_out_phrase_or_error ch outcome 136 | with Invalid_argument msg as e -> 137 | (* The marshalling failed *) 138 | let msg = "oloop-top: sending the phrase eval outcome failed \ 139 | because: " ^ msg in 140 | let err = Error(`Internal_error(Printexc.to_string e), msg) in 141 | send_out_phrase_or_error ch err 142 | 143 | (* This function is inspired by the compiler [Toploop.load_ocamlinit]. 144 | This latter function cannot be used instead because we want to 145 | report back to the library the outcome of this command (and it is 146 | not exported anyway!). 147 | [fname = ""] means to use the standard ".ocamlinit" file. *) 148 | let load_ocamlinit ch fname = 149 | let buf = Buffer.create 128 in 150 | let ppf = Format.formatter_of_buffer buf in 151 | let ok = 152 | if fname = "" then ( 153 | if Sys.file_exists ".ocamlinit" then Toploop.use_silently ppf ".ocamlinit" 154 | else 155 | try 156 | let home_init = Filename.concat (Sys.getenv "HOME") ".ocamlinit" in 157 | if Sys.file_exists home_init then Toploop.use_silently ppf home_init 158 | else true (* No .ocamlinit, that's fine. *) 159 | with Not_found -> true 160 | ) 161 | else ( 162 | if Sys.file_exists fname then Toploop.use_silently ppf fname 163 | else (Format.fprintf ppf "Init file not found: \"%s\".@." fname; false) 164 | ) in 165 | Format.pp_print_flush ppf (); 166 | Oloop_types.(send_init_outcome ch { init_ok = ok; 167 | init_out = Buffer.contents buf }) 168 | 169 | 170 | let main ~msg_with_location ~redirect_stderr ~sock_name = 171 | initialize_toplevel ~redirect_stderr; 172 | let ch = (* or exn *) 173 | let fd = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in 174 | Unix.connect fd (Unix.ADDR_UNIX sock_name); 175 | Unix.out_channel_of_descr fd in 176 | while true do 177 | Location.reset(); 178 | match Oloop_types.read stdin with 179 | | Phrase phrase -> 180 | eval_and_send ch phrase ~msg_with_location ~redirect_stderr 181 | | Init fname -> 182 | load_ocamlinit ch fname 183 | done 184 | 185 | let () = 186 | let sock_name = ref "" in 187 | let msg_with_location = ref false in 188 | let redirect_stderr = ref false in 189 | (* These options must correspond to optional arguments in [Oloop.create]. *) 190 | let specs = [ 191 | ("--sock", Arg.Set_string sock_name, 192 | " the name of the Unix socket on which to send eval outcome"); 193 | ("-I", Arg.String(fun p -> Clflags.include_dirs 194 | := p :: !Clflags.include_dirs), 195 | " Add to the list of include directories"); 196 | ("--no-app-funct", Arg.Clear Clflags.applicative_functors, 197 | " Deactivate applicative functors"); 198 | ("--principal", Arg.Set Clflags.principal, 199 | " Check principality of type inference"); 200 | ("--rectypes", Arg.Set Clflags.recursive_types, 201 | " Allow arbitrary recursive types"); 202 | ("--short-paths", Arg.Clear Clflags.real_paths, 203 | " Shorten paths in types"); 204 | ("--strict-sequence", Arg.Set Clflags.strict_sequence, 205 | " Left-hand part of a sequence must have type unit"); 206 | ("--thread", Arg.Set Clflags.use_threads, 207 | " Generate code that supports the system threads library"); 208 | ("--msg-with-location", Arg.Set msg_with_location, 209 | " Add the source location to error messages"); 210 | ("--redirect-stderr", Arg.Set redirect_stderr, 211 | " Redirect stderr to stdout"); 212 | ("--determine-deferred", Arg.Unit(fun () -> Rule.(enable async)), 213 | " Determine anonymous Deferred.t values (as Utop does)"); 214 | ("--determine-lwt", Arg.Unit(fun () -> Rule.(enable lwt)), 215 | " Determine anonymous Lwt.t values (as Utop does)"); 216 | ] in 217 | let specs = Arg.align specs in 218 | let anon_fun _ = raise(Arg.Bad "No anomymous argument") in 219 | Arg.parse specs anon_fun "oloop-top [options]"; 220 | main ~msg_with_location:!msg_with_location 221 | ~redirect_stderr:!redirect_stderr 222 | ~sock_name:!sock_name 223 | -------------------------------------------------------------------------------- /lib/oloop.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel.Std 2 | open Async.Std 3 | 4 | module Script = Oloop_script 5 | module Raw_script = Oloop_raw_script 6 | module Outcome = Oloop_outcome 7 | 8 | let default_toplevel = ref Oloop_conf.default_toplevel 9 | 10 | type 'a t = { 11 | proc: Process.t; 12 | sock_path: string; (* unix socket name *) 13 | sock: Reader.t; (* socket for the outcome of eval *) 14 | silent_directives: bool; 15 | kind: 'a Outcome.kind; 16 | } 17 | 18 | type 'a ocaml_args = 19 | ?include_dirs: string list -> 20 | ?no_app_functors: unit -> 21 | ?principal: unit -> 22 | ?rectypes: unit -> 23 | ?short_paths: unit -> 24 | ?strict_sequence: unit -> 25 | ?thread: unit -> 26 | 'a 27 | 28 | type 'a args = ( 29 | ?prog: string -> 30 | ?working_dir: string -> 31 | ?msg_with_location: unit -> 32 | ?silent_directives: unit -> 33 | ?determine_deferred: unit -> 34 | ?determine_lwt: unit -> 35 | 'a 36 | ) ocaml_args 37 | 38 | let present = function 39 | | Some () -> true 40 | | None -> false 41 | 42 | let check_toploop_exists prog = 43 | (* Process.create hangs if prog does not exists. We want to 44 | immediately report an error. *) 45 | Unix.access prog [`Exec] >>| function 46 | | Result.Ok() as r -> r 47 | | Result.Error e0 -> 48 | let e1 = Invalid_argument(sprintf "Toploop %S not executable" prog) in 49 | Result.Error(Error.of_list [Error.of_exn e1; Error.of_exn e0]) 50 | 51 | let create ?(include_dirs=[]) ?no_app_functors ?principal 52 | ?rectypes ?short_paths ?strict_sequence ?thread 53 | ?(prog = !default_toplevel) ?working_dir ?msg_with_location 54 | ?silent_directives ?determine_deferred ?determine_lwt 55 | output_merged = 56 | let prog = match working_dir with 57 | | None -> prog 58 | | Some d -> if Filename.is_relative prog then Filename.concat d prog 59 | else prog in 60 | check_toploop_exists prog >>=? fun () -> 61 | let sock_path = Filename.temp_file "oloop" ".fifo" in 62 | Unix.unlink sock_path >>= fun () -> 63 | let sock = Socket.create Socket.Type.unix in 64 | Socket.bind sock (`Unix sock_path) >>= fun sock -> 65 | (* Make sure [t.sock_path] is removed when the program exits: *) 66 | at_exit(fun () -> try Core.Std.Unix.unlink sock_path with _ -> ()); 67 | let args = ["--sock"; sock_path] in 68 | let args = List.fold include_dirs ~init:args 69 | ~f:(fun args dir -> "-I" :: dir :: args) in 70 | let args = if present no_app_functors then "--no-app-funct" :: args 71 | else args in 72 | let args = if present principal then "--principal" :: args else args in 73 | let args = if present rectypes then "--rectypes" :: args else args in 74 | let args = if present short_paths then "--short-paths" :: args else args in 75 | let args = if present strict_sequence then "--strict-sequence" :: args 76 | else args in 77 | let args = if present thread then "--thread" :: args 78 | else args in 79 | let args = if present msg_with_location then "--msg-with-location" :: args 80 | else args in 81 | let args = if present determine_deferred then "--determine-deferred" :: args 82 | else args in 83 | let args = if present determine_lwt then "--determine-lwt" :: args 84 | else args in 85 | let args = match Outcome.kind output_merged with 86 | | `Merged -> "--redirect-stderr" :: args 87 | | `Separate -> args in 88 | (* Make sure that the input phrase is not reprinted: *) 89 | let env = ["TERM", "norepeat"] in 90 | Process.create ?working_dir ~prog ~args ~env:(`Extend env) () >>=? fun proc -> 91 | (* Wait for the oloop-top client to connect: *) 92 | Socket.accept (Socket.listen sock) >>= function 93 | | `Ok(conn_sock, _) -> 94 | Unix.close (Socket.fd sock) >>= fun () -> 95 | let sock = Reader.create (Socket.fd conn_sock) in 96 | return(Result.Ok { proc; sock_path; sock; 97 | silent_directives = present silent_directives; 98 | kind = output_merged }) 99 | | `Socket_closed -> 100 | let msg = "Oloop.create: toplevel not started" in 101 | return(Result.Error(Error.of_string msg)) 102 | 103 | let send t (x: Oloop_types.top_input) = 104 | let top = Process.stdin t.proc in 105 | Writer.write_marshal top x ~flags:[]; 106 | Writer.flushed top 107 | 108 | let close t = 109 | send t (Oloop_types.Phrase "exit 0;;") >>= fun () -> (* exit the toploop *) 110 | Writer.close (Process.stdin t.proc) >>= fun () -> 111 | Reader.close (Process.stdout t.proc) >>= fun () -> 112 | Reader.close (Process.stderr t.proc) >>= fun () -> 113 | Unix.wait (`Pid(Process.pid t.proc)) >>= fun _ -> 114 | Reader.close t.sock >>= fun () -> 115 | Unix.unlink t.sock_path 116 | 117 | let with_toploop ?include_dirs ?no_app_functors ?principal 118 | ?rectypes ?short_paths ?strict_sequence ?thread 119 | ?prog ?working_dir ?msg_with_location 120 | ?silent_directives ?determine_deferred ?determine_lwt 121 | output_merged ~f = 122 | create ?prog ?working_dir ?include_dirs ?no_app_functors ?principal 123 | ?rectypes ?short_paths ?strict_sequence ?thread ?msg_with_location 124 | ?silent_directives ?determine_deferred ?determine_lwt 125 | output_merged 126 | >>= function 127 | | Result.Ok t -> (try f t 128 | with e -> close t >>= fun () -> raise e) 129 | >>= fun r -> close t 130 | >>= fun () -> return r 131 | | Result.Error _ as e -> return e 132 | 133 | 134 | let reader_to_string r = 135 | Reader.read_until r (`Char Oloop_types.end_output) ~keep_delim:false 136 | >>| function 137 | | `Eof -> "" 138 | | `Eof_without_delim s -> s 139 | | `Ok s -> s 140 | 141 | let eval (t: 'a t) phrase = 142 | send t (Oloop_types.Phrase phrase) 143 | (* FIXME: Maybe the output of the previous phrase was not yet 144 | collected. Must use a queue to serialize phrase → outcome *) 145 | >>= fun () -> 146 | Reader.read_marshal t.sock 147 | >>= fun (out_phrase: Oloop_types.out_phrase_or_error Reader.Read_result.t) -> 148 | reader_to_string (Process.stdout t.proc) >>= fun stdout -> 149 | reader_to_string (Process.stderr t.proc) >>= fun stderr -> 150 | match out_phrase with 151 | | `Ok(Oloop_types.Ok(r, is_directive, warnings)) -> 152 | (* TODO: Parse stderr for warnings *) 153 | let out_phrase = match r with 154 | | Oloop_types.Eval(ov, ot) -> 155 | Outcome.Eval(Oloop_types.to_outcometree_value ov, ot) 156 | | Oloop_types.Signature l -> 157 | Outcome.Signature(List.map ~f:Oloop_types.to_outcometree_sig l) 158 | | Oloop_types.Exception(e, ov) -> 159 | Outcome.Exception(Outcome.Exn.of_exn e, 160 | Oloop_types.to_outcometree_value ov) 161 | | Oloop_types.Exception_string(s, ov) -> 162 | Outcome.Exception(Outcome.Exn.of_string s, 163 | Oloop_types.to_outcometree_value ov) 164 | | Oloop_types.Exception_Stack_overflow ov -> 165 | Outcome.Exception(Outcome.Exn.of_exn Stack_overflow, 166 | Oloop_types.to_outcometree_value ov) 167 | in 168 | let result, stdout, stderr = 169 | if is_directive && t.silent_directives then 170 | (* Only silence the output if everything is fine. *) 171 | match out_phrase with 172 | | Outcome.Exception _ -> (out_phrase, stdout, stderr) 173 | | Outcome.Eval _ 174 | | Outcome.Signature _ -> (Outcome.Signature [], "", "") 175 | else (out_phrase, stdout, stderr) in 176 | return(`Eval(Outcome.make_eval ~result ~stdout ~stderr ~warnings t.kind)) 177 | | `Ok(Oloop_types.Error(e, msg)) -> 178 | (* When the code was not correclty evaluated, the [phrase] is 179 | outputted on stdout with terminal codes to underline the error 180 | location. Since we have access to the location, this is useless. *) 181 | return(`Uneval(Outcome.deserialize_to_uneval e, msg)) 182 | | `Eof -> 183 | return(`Uneval(`Internal_error "End of file", 184 | "The toploop did not return a result")) 185 | 186 | let init ?(file="") t = 187 | send t (Oloop_types.Init file) >>= fun () -> 188 | Reader.read_marshal t.sock 189 | >>= function 190 | | `Ok(o: Oloop_types.init_output) -> 191 | if o.Oloop_types.init_ok then return(Ok()) 192 | else return(Error(Error.of_string o.Oloop_types.init_out)) 193 | | `Eof -> 194 | return(Error(Error.of_string "Oloop.init: unexpected EOF")) 195 | 196 | let eval_script ?include_dirs ?no_app_functors ?principal 197 | ?rectypes ?short_paths ?strict_sequence ?thread 198 | ?prog ?working_dir ?msg_with_location 199 | ?silent_directives ?determine_deferred ?determine_lwt 200 | ?init:init_file ?noinit script = 201 | let eval_phrase oloop phrase : Script.Evaluated.phrase Deferred.t = 202 | eval oloop phrase >>| fun outcome -> 203 | {Script.Evaluated.phrase; outcome} 204 | in 205 | let eval_phrases oloop phrases : Script.Evaluated.phrase list Deferred.t = 206 | Deferred.List.fold phrases ~init:[] ~f:(fun accum phrase -> 207 | eval_phrase oloop phrase >>| fun x -> x::accum 208 | ) 209 | >>| List.rev 210 | in 211 | let eval_part oloop part : Script.Evaluated.part Deferred.t = 212 | let {Script.number; content} = part in 213 | let phrases = Script.phrases_of_string content in 214 | eval_phrases oloop phrases >>| fun phrases -> 215 | {Script.Evaluated.number; content; phrases} 216 | in 217 | let parts = (script : Script.t :> Script.part list) in 218 | let run t = 219 | (match noinit with 220 | | Some () -> return(Ok()) 221 | | None -> init ?file:init_file t) >>=? fun () -> 222 | Deferred.List.fold 223 | parts ~init:[] 224 | ~f:(fun accum part -> eval_part t part >>| fun x -> x::accum) 225 | >>| List.rev 226 | >>| fun x -> Ok x 227 | in 228 | with_toploop ?include_dirs ?no_app_functors ?principal 229 | ?rectypes ?short_paths ?strict_sequence ?thread 230 | ?prog ?working_dir ?msg_with_location 231 | ?silent_directives ?determine_deferred ?determine_lwt 232 | Outcome.merged ~f:run 233 | 234 | let eval_or_error t phrase = 235 | eval t phrase >>| function 236 | | `Eval x -> Ok x 237 | | `Uneval err -> Error(Outcome.uneval_to_error err) 238 | 239 | 240 | (******************************************************************************) 241 | (* Miscellaneous *) 242 | (******************************************************************************) 243 | let signatures_remove_underscore_names = 244 | Oloop_ocaml.signatures_remove_underscore_names 245 | 246 | let phrase_remove_underscore_names = 247 | Oloop_ocaml.phrase_remove_underscore_names 248 | 249 | module Location = struct 250 | include Location 251 | 252 | let sexp_of_t = Oloop_ocaml.Location.sexp_of_t 253 | let t_of_sexp = Oloop_ocaml.Location.t_of_sexp 254 | end 255 | ;; 256 | -------------------------------------------------------------------------------- /lib/oloop_types.mlp: -------------------------------------------------------------------------------- 1 | (* Types shared between the Oloop module and the oloop-top executable 2 | to ensure typed communication. *) 3 | 4 | open Types (* compiler types *) 5 | 6 | (* 7 | * Toploop input 8 | *) 9 | 10 | type top_input = 11 | | Phrase of string 12 | | Init of string 13 | 14 | let read ch = (input_value ch : top_input) 15 | (* [send] declared in [Oloop] because it depends on [Core]. *) 16 | 17 | (* 18 | * out_phrase 19 | *) 20 | 21 | type pp_directive = 22 | | String of string 23 | | Newline 24 | | Spaces of int 25 | 26 | let recorder l = 27 | let out_string s ofs len = l := String(String.sub s ofs len) :: !l in 28 | let out_flush () = () in 29 | let out_newline () = l := Newline :: !l in 30 | let out_spaces n = l := Spaces n :: !l in 31 | let fmt = Format.make_formatter out_string out_flush in 32 | Format.pp_set_formatter_out_functions 33 | fmt { Format.out_string; out_flush; out_newline; out_spaces }; 34 | fmt 35 | 36 | let record (pp: Format.formatter -> unit) = 37 | let l = ref [] in 38 | let fmt = recorder l in 39 | pp fmt; 40 | Format.pp_print_flush fmt (); 41 | List.rev !l 42 | 43 | let play_directive fmt = function 44 | | String s -> Format.pp_print_string fmt s 45 | | Newline -> Format.pp_force_newline fmt () 46 | | Spaces n -> for _i = 1 to n do Format.pp_print_space fmt () done 47 | 48 | let replay l fmt = 49 | Format.pp_open_hvbox fmt 0; 50 | List.iter (play_directive fmt) l; 51 | Format.pp_close_box fmt () 52 | 53 | (* Outcometree.out_phrase contains a closure (which cannot be 54 | marshalled) to handle arbitrary pretty printers. Play it on a 55 | recording formatter to keep most of it. *) 56 | 57 | type serializable_out_value = 58 | | Array of serializable_out_value list 59 | | Char of char 60 | | Constr of Outcometree.out_ident * serializable_out_value list 61 | | Ellipsis 62 | | Float of float 63 | | Int of int 64 | | Int32 of int32 65 | | Int64 of int64 66 | | Nativeint of nativeint 67 | | List of serializable_out_value list 68 | | Printer of pp_directive list 69 | | Record of (Outcometree.out_ident * serializable_out_value) list 70 | | String of string 71 | | Stuff of string 72 | | Tuple of serializable_out_value list 73 | | Variant of string * serializable_out_value option 74 | 75 | (* The [Exception_string] is used if [exn] is not serializable. *) 76 | type serializable_out_phrase = 77 | | Eval of serializable_out_value * Outcometree.out_type 78 | | Signature of (Outcometree.out_sig_item * serializable_out_value option) list 79 | | Exception of (exn * serializable_out_value) 80 | | Exception_string of (string * serializable_out_value) 81 | | Exception_Stack_overflow of serializable_out_value 82 | 83 | let empty = Signature [] 84 | 85 | let rec of_outcometree_value = 86 | let open Outcometree in 87 | function 88 | | Oval_array l -> Array(List.map of_outcometree_value l) 89 | | Oval_char c -> Char c 90 | | Oval_constr(oi, ov) -> Constr(oi, List.map of_outcometree_value ov) 91 | | Oval_ellipsis -> Ellipsis 92 | | Oval_float f -> Float f 93 | | Oval_int i -> Int i 94 | | Oval_int32 i -> Int32 i 95 | | Oval_int64 i -> Int64 i 96 | | Oval_nativeint i -> Nativeint i 97 | | Oval_list l -> List(List.map of_outcometree_value l) 98 | | Oval_printer p -> Printer(record p) 99 | | Oval_record l -> Record(List.map of_outcometree_record l) 100 | | Oval_string s -> String s 101 | | Oval_stuff s -> Stuff s 102 | | Oval_tuple ov -> Tuple(List.map of_outcometree_value ov) 103 | | Oval_variant(s, None) -> Variant(s, None) 104 | | Oval_variant(s, Some ov) -> Variant(s, Some(of_outcometree_value ov)) 105 | and of_outcometree_record (oi, ov) = 106 | (oi, of_outcometree_value ov) 107 | 108 | let of_outcometree_sig (si, maybe_ov) = 109 | match maybe_ov with 110 | | None -> (si, None) 111 | | Some ov -> (si, Some(of_outcometree_value ov)) 112 | 113 | let of_outcometree_phrase = 114 | let open Outcometree in 115 | function 116 | | Ophr_eval(ov, ot) -> Eval(of_outcometree_value ov, ot) 117 | | Ophr_signature l -> Signature(List.map of_outcometree_sig l) 118 | | Ophr_exception(e, ov) -> Exception(e, of_outcometree_value ov) 119 | 120 | 121 | let rec to_outcometree_value = 122 | let open Outcometree in 123 | function 124 | | Array l -> Oval_array(List.map to_outcometree_value l) 125 | | Char c -> Oval_char c 126 | | Constr(oi, ov) -> Oval_constr(oi, List.map to_outcometree_value ov) 127 | | Ellipsis -> Oval_ellipsis 128 | | Float f -> Oval_float f 129 | | Int i -> Oval_int i 130 | | Int32 i -> Oval_int32 i 131 | | Int64 i -> Oval_int64 i 132 | | Nativeint i -> Oval_nativeint i 133 | | List l -> Oval_list(List.map to_outcometree_value l) 134 | | Printer p -> Oval_printer(replay p) 135 | | Record l -> Oval_record(List.map to_outcometree_record l) 136 | | String s -> Oval_string s 137 | | Stuff s -> Oval_stuff s 138 | | Tuple ov -> Oval_tuple(List.map to_outcometree_value ov) 139 | | Variant(s, None) -> Oval_variant(s, None) 140 | | Variant(s, Some ov) -> Oval_variant(s, Some(to_outcometree_value ov)) 141 | and to_outcometree_record (oi, ov) = 142 | (oi, to_outcometree_value ov) 143 | 144 | let to_outcometree_sig (si, maybe_ov) = 145 | match maybe_ov with 146 | | None -> (si, None) 147 | | Some ov -> (si, Some(to_outcometree_value ov)) 148 | 149 | (* 150 | * Errors 151 | *) 152 | 153 | (* Several errors contain Env.t which is not serializable because it 154 | contains a closure. Convert the Env.t to their summary. *) 155 | 156 | type serializable_typedecl_error = 157 | | S_Repeated_parameter 158 | | S_Duplicate_constructor of string 159 | | S_Too_many_constructors 160 | | S_Duplicate_label of string 161 | | S_Recursive_abbrev of string 162 | #if OCAML_VERSION >= (4, 02, 0) 163 | | S_Cycle_in_def of string * type_expr 164 | #endif 165 | | S_Definition_mismatch of type_expr * Includecore.type_mismatch list 166 | | S_Constraint_failed of type_expr * type_expr 167 | | S_Inconsistent_constraint of Env.summary * (type_expr * type_expr) list 168 | | S_Type_clash of Env.summary * (type_expr * type_expr) list 169 | | S_Parameters_differ of Path.t * type_expr * type_expr 170 | | S_Null_arity_external 171 | | S_Missing_native_external 172 | | S_Unbound_type_var of type_expr * type_declaration 173 | #if OCAML_VERSION < (4, 02, 0) 174 | | S_Unbound_exception of Longident.t 175 | | S_Not_an_exception of Longident.t 176 | #else 177 | | S_Not_open_type of Path.t 178 | | S_Not_extensible_type of Path.t 179 | | S_Extension_mismatch of Path.t * Includecore.type_mismatch list 180 | | S_Rebind_wrong_type of 181 | Longident.t * Env.summary * (type_expr * type_expr) list 182 | | S_Rebind_mismatch of Longident.t * Path.t * Path.t 183 | | S_Rebind_private of Longident.t 184 | #endif 185 | | S_Bad_variance of int * (bool*bool*bool) * (bool*bool*bool) 186 | | S_Unavailable_type_constructor of Path.t 187 | | S_Bad_fixed_type of string 188 | #if OCAML_VERSION < (4, 02, 0) 189 | | S_Unbound_type_var_exc of type_expr * type_expr 190 | #else 191 | | S_Unbound_type_var_ext of type_expr * extension_constructor 192 | #endif 193 | | S_Varying_anonymous 194 | 195 | 196 | let serialize_typedecl_error = 197 | let open Typedecl in 198 | function 199 | | Repeated_parameter -> S_Repeated_parameter 200 | | Duplicate_constructor s -> S_Duplicate_constructor s 201 | | Too_many_constructors -> S_Too_many_constructors 202 | | Duplicate_label s -> S_Duplicate_label s 203 | | Recursive_abbrev s -> S_Recursive_abbrev s 204 | #if OCAML_VERSION >= (4, 02, 0) 205 | | Cycle_in_def(s, e) -> S_Cycle_in_def(s, e) 206 | #endif 207 | | Definition_mismatch(e, l) -> S_Definition_mismatch(e, l) 208 | | Constraint_failed(e1, e2) -> S_Constraint_failed(e1, e2) 209 | | Inconsistent_constraint(env, l) -> 210 | S_Inconsistent_constraint(Env.summary env, l) 211 | | Type_clash(env, l) -> S_Type_clash(Env.summary env, l) 212 | | Parameters_differ(p, e1, e2) -> S_Parameters_differ(p, e1, e2) 213 | | Null_arity_external -> S_Null_arity_external 214 | | Missing_native_external -> S_Missing_native_external 215 | | Unbound_type_var(e, d) -> S_Unbound_type_var(e, d) 216 | #if OCAML_VERSION < (4, 02, 0) 217 | | Unbound_exception id -> S_Unbound_exception id 218 | | Not_an_exception id -> S_Not_an_exception id 219 | #else 220 | | Not_open_type p -> S_Not_open_type p 221 | | Not_extensible_type p -> S_Not_extensible_type p 222 | | Extension_mismatch(p, l) -> S_Extension_mismatch(p, l) 223 | | Rebind_wrong_type(id, env, l) -> 224 | S_Rebind_wrong_type(id, Env.summary env, l) 225 | | Rebind_mismatch(id, p1, p2) -> S_Rebind_mismatch(id, p1, p2) 226 | | Rebind_private id -> S_Rebind_private id 227 | #endif 228 | | Bad_variance(i, b1, b2) -> S_Bad_variance(i, b1, b2) 229 | | Unavailable_type_constructor p -> S_Unavailable_type_constructor p 230 | | Bad_fixed_type s -> S_Bad_fixed_type s 231 | #if OCAML_VERSION < (4, 02, 0) 232 | | Unbound_type_var_exc(e1, e2) -> S_Unbound_type_var_exc(e1, e2) 233 | #else 234 | | Unbound_type_var_ext (e, c) -> S_Unbound_type_var_ext(e, c) 235 | #endif 236 | | Varying_anonymous -> S_Varying_anonymous 237 | 238 | 239 | (* [env_of_summary] requires that the path and initial environment are 240 | initialized. This is not necessary for the toploop thus is done in 241 | [Oloop_ocaml] for the main program only. *) 242 | let deserialize_typedecl_error ~env_of_summary = 243 | let open Typedecl in 244 | function 245 | | S_Repeated_parameter -> Repeated_parameter 246 | | S_Duplicate_constructor s -> Duplicate_constructor s 247 | | S_Too_many_constructors -> Too_many_constructors 248 | | S_Duplicate_label s -> Duplicate_label s 249 | | S_Recursive_abbrev s -> Recursive_abbrev s 250 | #if OCAML_VERSION >= (4, 02, 0) 251 | | S_Cycle_in_def(s, e) -> Cycle_in_def(s, e) 252 | #endif 253 | | S_Definition_mismatch(e, l) -> Definition_mismatch(e, l) 254 | | S_Constraint_failed(e1, e2) -> Constraint_failed(e1, e2) 255 | | S_Inconsistent_constraint(env, l) -> 256 | Inconsistent_constraint(env_of_summary env, l) 257 | | S_Type_clash(env, l) -> Type_clash(env_of_summary env, l) 258 | | S_Parameters_differ(p, e1, e2) -> Parameters_differ(p, e1, e2) 259 | | S_Null_arity_external -> Null_arity_external 260 | | S_Missing_native_external -> Missing_native_external 261 | | S_Unbound_type_var(e, d) -> Unbound_type_var(e, d) 262 | #if OCAML_VERSION < (4, 02, 0) 263 | | S_Unbound_exception id -> Unbound_exception id 264 | | S_Not_an_exception id -> Not_an_exception id 265 | #else 266 | | S_Not_open_type p -> Not_open_type p 267 | | S_Not_extensible_type p -> Not_extensible_type p 268 | | S_Extension_mismatch(p, l) -> Extension_mismatch(p, l) 269 | | S_Rebind_wrong_type(id, env, l) -> 270 | Rebind_wrong_type(id, env_of_summary env, l) 271 | | S_Rebind_mismatch(id, p1, p2) -> Rebind_mismatch(id, p1, p2) 272 | | S_Rebind_private id -> Rebind_private id 273 | #endif 274 | | S_Bad_variance(i, b1, b2) -> Bad_variance(i, b1, b2) 275 | | S_Unavailable_type_constructor p -> Unavailable_type_constructor p 276 | | S_Bad_fixed_type s -> Bad_fixed_type s 277 | #if OCAML_VERSION < (4, 02, 0) 278 | | S_Unbound_type_var_exc(e1, e2) -> Unbound_type_var_exc(e1, e2) 279 | #else 280 | | S_Unbound_type_var_ext (e, c) -> Unbound_type_var_ext(e, c) 281 | #endif 282 | | S_Varying_anonymous -> Varying_anonymous 283 | 284 | 285 | type serializable_ctype_class_match_failure = 286 | | S_CM_Virtual_class 287 | | S_CM_Parameter_arity_mismatch of int * int 288 | | S_CM_Type_parameter_mismatch of Env.summary * (type_expr * type_expr) list 289 | | S_CM_Class_type_mismatch of Env.summary * class_type * class_type 290 | | S_CM_Parameter_mismatch of Env.summary * (type_expr * type_expr) list 291 | | S_CM_Val_type_mismatch of string * Env.summary 292 | * (type_expr * type_expr) list 293 | | S_CM_Meth_type_mismatch of string * Env.summary 294 | * (type_expr * type_expr) list 295 | | S_CM_Non_mutable_value of string 296 | | S_CM_Non_concrete_value of string 297 | | S_CM_Missing_value of string 298 | | S_CM_Missing_method of string 299 | | S_CM_Hide_public of string 300 | | S_CM_Hide_virtual of string * string 301 | | S_CM_Public_method of string 302 | | S_CM_Private_method of string 303 | | S_CM_Virtual_method of string 304 | 305 | let serialize_ctype_class_match_failure = 306 | let open Ctype in 307 | function 308 | | CM_Virtual_class -> S_CM_Virtual_class 309 | | CM_Parameter_arity_mismatch(i, j) -> S_CM_Parameter_arity_mismatch(i, j) 310 | | CM_Type_parameter_mismatch(env,l) -> 311 | S_CM_Type_parameter_mismatch(Env.summary env, l) 312 | | CM_Class_type_mismatch(env, c1, c2) -> 313 | S_CM_Class_type_mismatch(Env.summary env, c1, c2) 314 | | CM_Parameter_mismatch(env, l) -> 315 | S_CM_Parameter_mismatch(Env.summary env, l) 316 | | CM_Val_type_mismatch(s, env, l) -> 317 | S_CM_Val_type_mismatch(s, Env.summary env, l) 318 | | CM_Meth_type_mismatch(s, env, l) -> 319 | S_CM_Meth_type_mismatch(s, Env.summary env, l) 320 | | CM_Non_mutable_value s -> S_CM_Non_mutable_value s 321 | | CM_Non_concrete_value s -> S_CM_Non_concrete_value s 322 | | CM_Missing_value s -> S_CM_Missing_value s 323 | | CM_Missing_method s -> S_CM_Missing_method s 324 | | CM_Hide_public s -> S_CM_Hide_public s 325 | | CM_Hide_virtual(s1, s2) -> S_CM_Hide_virtual(s1, s2) 326 | | CM_Public_method s -> S_CM_Public_method s 327 | | CM_Private_method s -> S_CM_Private_method s 328 | | CM_Virtual_method s -> S_CM_Virtual_method s 329 | 330 | let deserialize_ctype_class_match_failure ~env_of_summary = 331 | let open Ctype in 332 | function 333 | | S_CM_Virtual_class -> CM_Virtual_class 334 | | S_CM_Parameter_arity_mismatch(i, j) -> CM_Parameter_arity_mismatch(i, j) 335 | | S_CM_Type_parameter_mismatch(env,l) -> 336 | CM_Type_parameter_mismatch(env_of_summary env, l) 337 | | S_CM_Class_type_mismatch(env, c1, c2) -> 338 | CM_Class_type_mismatch(env_of_summary env, c1, c2) 339 | | S_CM_Parameter_mismatch(env, l) -> 340 | CM_Parameter_mismatch(env_of_summary env, l) 341 | | S_CM_Val_type_mismatch(s, env, l) -> 342 | CM_Val_type_mismatch(s, env_of_summary env, l) 343 | | S_CM_Meth_type_mismatch(s, env, l) -> 344 | CM_Meth_type_mismatch(s, env_of_summary env, l) 345 | | S_CM_Non_mutable_value s -> CM_Non_mutable_value s 346 | | S_CM_Non_concrete_value s -> CM_Non_concrete_value s 347 | | S_CM_Missing_value s -> CM_Missing_value s 348 | | S_CM_Missing_method s -> CM_Missing_method s 349 | | S_CM_Hide_public s -> CM_Hide_public s 350 | | S_CM_Hide_virtual(s1, s2) -> CM_Hide_virtual(s1, s2) 351 | | S_CM_Public_method s -> CM_Public_method s 352 | | S_CM_Private_method s -> CM_Private_method s 353 | | S_CM_Virtual_method s -> CM_Virtual_method s 354 | 355 | 356 | type serializable_typeclass_error = 357 | | S_Unconsistent_constraint of (type_expr * type_expr) list 358 | | S_Field_type_mismatch of string * string * (type_expr * type_expr) list 359 | | S_Structure_expected of class_type 360 | | S_Cannot_apply of class_type 361 | #if OCAML_VERSION >= (4, 03, 0) 362 | | S_Apply_wrong_label of arg_label 363 | #else 364 | | S_Apply_wrong_label of Asttypes.label 365 | #endif 366 | | S_Pattern_type_clash of type_expr 367 | | S_Repeated_parameter 368 | | S_Unbound_class_2 of Longident.t 369 | | S_Unbound_class_type_2 of Longident.t 370 | | S_Abbrev_type_clash of type_expr * type_expr * type_expr 371 | | S_Constructor_type_mismatch of string * (type_expr * type_expr) list 372 | #if OCAML_VERSION <= (4, 01, 0) 373 | | S_Virtual_class of bool * string list * string list 374 | #else 375 | | S_Virtual_class of bool * bool * string list * string list 376 | #endif 377 | | S_Parameter_arity_mismatch of Longident.t * int * int 378 | | S_Parameter_mismatch of (type_expr * type_expr) list 379 | | S_Bad_parameters of Ident.t * type_expr * type_expr 380 | | S_Class_match_failure of serializable_ctype_class_match_failure list 381 | | S_Unbound_val of string 382 | | S_Unbound_type_var of pp_directive list * Ctype.closed_class_failure 383 | | S_Make_nongen_seltype of type_expr 384 | | S_Non_generalizable_class of Ident.t * Types.class_declaration 385 | | S_Cannot_coerce_self of type_expr 386 | | S_Non_collapsable_conjunction of 387 | Ident.t * Types.class_declaration * (type_expr * type_expr) list 388 | | S_Final_self_clash of (type_expr * type_expr) list 389 | | S_Mutability_mismatch of string * Asttypes.mutable_flag 390 | | S_No_overriding of string * string 391 | | S_Duplicate of string * string 392 | 393 | let serialize_typeclass_error = 394 | let open Typeclass in 395 | function 396 | | Unconsistent_constraint l -> S_Unconsistent_constraint l 397 | | Field_type_mismatch(s1, s2, l) -> S_Field_type_mismatch(s1, s2, l) 398 | | Structure_expected c -> S_Structure_expected c 399 | | Cannot_apply c -> S_Cannot_apply c 400 | | Apply_wrong_label l -> S_Apply_wrong_label l 401 | | Pattern_type_clash t -> S_Pattern_type_clash t 402 | | Repeated_parameter -> S_Repeated_parameter 403 | | Unbound_class_2 l -> S_Unbound_class_2 l 404 | | Unbound_class_type_2 l -> S_Unbound_class_type_2 l 405 | | Abbrev_type_clash(t1, t2, t3) -> S_Abbrev_type_clash(t1, t2, t3) 406 | | Constructor_type_mismatch(s, l) -> S_Constructor_type_mismatch(s, l) 407 | #if OCAML_VERSION <= (4, 01, 0) 408 | | Virtual_class(b, l1, l2) -> S_Virtual_class(b, l1, l2) 409 | #else 410 | | Virtual_class(b1, b2, l1, l2) -> S_Virtual_class(b1, b2, l1, l2) 411 | #endif 412 | | Parameter_arity_mismatch(l, i, j) -> S_Parameter_arity_mismatch(l, i, j) 413 | | Parameter_mismatch l -> S_Parameter_mismatch l 414 | | Bad_parameters(id, e1, e2) -> S_Bad_parameters(id, e1, e2) 415 | | Class_match_failure l -> 416 | let l = List.map serialize_ctype_class_match_failure l in 417 | S_Class_match_failure l 418 | | Unbound_val s -> S_Unbound_val s 419 | | Unbound_type_var (pr, f) -> S_Unbound_type_var(record pr, f) 420 | | Make_nongen_seltype t -> S_Make_nongen_seltype t 421 | | Non_generalizable_class(id, c) -> S_Non_generalizable_class(id, c) 422 | | Cannot_coerce_self t -> S_Cannot_coerce_self t 423 | | Non_collapsable_conjunction(id, d, l) -> 424 | S_Non_collapsable_conjunction(id, d, l) 425 | | Final_self_clash l -> S_Final_self_clash l 426 | | Mutability_mismatch(s, f) -> S_Mutability_mismatch(s, f) 427 | | No_overriding(s1, s2) -> S_No_overriding(s1, s2) 428 | | Duplicate(s1, s2) -> S_Duplicate(s1, s2) 429 | 430 | let deserialize_typeclass_error ~env_of_summary = 431 | let open Typeclass in 432 | function 433 | | S_Unconsistent_constraint l -> Unconsistent_constraint l 434 | | S_Field_type_mismatch(s1, s2, l) -> Field_type_mismatch(s1, s2, l) 435 | | S_Structure_expected c -> Structure_expected c 436 | | S_Cannot_apply c -> Cannot_apply c 437 | | S_Apply_wrong_label l -> Apply_wrong_label l 438 | | S_Pattern_type_clash t -> Pattern_type_clash t 439 | | S_Repeated_parameter -> Repeated_parameter 440 | | S_Unbound_class_2 l -> Unbound_class_2 l 441 | | S_Unbound_class_type_2 l -> Unbound_class_type_2 l 442 | | S_Abbrev_type_clash(t1, t2, t3) -> Abbrev_type_clash(t1, t2, t3) 443 | | S_Constructor_type_mismatch(s, l) -> Constructor_type_mismatch(s, l) 444 | #if OCAML_VERSION <= (4, 01, 0) 445 | | S_Virtual_class(b, l1, l2) -> Virtual_class(b, l1, l2) 446 | #else 447 | | S_Virtual_class(b1, b2, l1, l2) -> Virtual_class(b1, b2, l1, l2) 448 | #endif 449 | | S_Parameter_arity_mismatch(l, i, j) -> Parameter_arity_mismatch(l, i, j) 450 | | S_Parameter_mismatch l -> Parameter_mismatch l 451 | | S_Bad_parameters(id, e1, e2) -> Bad_parameters(id, e1, e2) 452 | | S_Class_match_failure l -> 453 | let m = List.map (deserialize_ctype_class_match_failure ~env_of_summary) 454 | l in 455 | Class_match_failure m 456 | | S_Unbound_val s -> Unbound_val s 457 | | S_Unbound_type_var (pr, f) -> Unbound_type_var(replay pr, f) 458 | | S_Make_nongen_seltype t -> Make_nongen_seltype t 459 | | S_Non_generalizable_class(id, c) -> Non_generalizable_class(id, c) 460 | | S_Cannot_coerce_self t -> Cannot_coerce_self t 461 | | S_Non_collapsable_conjunction(id, d, l) -> 462 | Non_collapsable_conjunction(id, d, l) 463 | | S_Final_self_clash l -> Final_self_clash l 464 | | S_Mutability_mismatch(s, f) -> Mutability_mismatch(s, f) 465 | | S_No_overriding(s1, s2) -> No_overriding(s1, s2) 466 | | S_Duplicate(s1, s2) -> Duplicate(s1, s2) 467 | 468 | type serializable_error = 469 | [ `Lexer of Location.t * Lexer.error 470 | | `Syntaxerr of Syntaxerr.error 471 | | `Typedecl of Location.t * serializable_typedecl_error 472 | | `Typetexp of Location.t * Env.summary * Typetexp.error 473 | | `Typecore of Location.t * Env.summary * Typecore.error 474 | | `Typeclass of Location.t * Env.summary * serializable_typeclass_error 475 | | `Symtable of Symtable.error 476 | | `Internal_error of string ] 477 | 478 | 479 | (** Outcome of evaluating toplevel phrases. 480 | - [OK] means that the phrase was correctly evaluated (if the 481 | phrase raises an exception, it is reported this way too). 482 | - [Error (e, s)] means that the phrases were not evaluated 483 | correctly because of a syntax error [e = `Syntaxerr _], a 484 | type error [e = `Typecore _], an unbound module [e = 485 | `Typetexp _], etc. 486 | The string is the explanation the toplevel would display 487 | (or an explanation of the error in case of [`Internal_error]). *) 488 | type out_phrase_or_error = 489 | | Ok of serializable_out_phrase * bool * (Location.t * Warnings.t) list 490 | | Error of (serializable_error * string) 491 | 492 | let output_out_phrase_or_error ch (o: out_phrase_or_error) = 493 | output_value ch o; 494 | flush ch 495 | 496 | let send_out_phrase_or_error ch o = 497 | match o with 498 | | Ok(Exception(Stack_overflow, v), b, l) -> 499 | output_out_phrase_or_error ch (Ok(Exception_Stack_overflow v, b, l)) 500 | | Ok(Exception(e, v), b, l) -> 501 | (try output_out_phrase_or_error ch o 502 | with Invalid_argument _ -> 503 | let e = Printexc.to_string e in 504 | output_out_phrase_or_error ch (Ok(Exception_string(e, v), b, l))) 505 | | _ -> output_out_phrase_or_error ch o 506 | 507 | let end_output = '\x04' 508 | 509 | (* 510 | * Init output 511 | *) 512 | 513 | type init_output = { init_ok: bool; 514 | init_out: string } 515 | 516 | let send_init_outcome ch (o: init_output) = 517 | output_value ch o; 518 | flush ch 519 | -------------------------------------------------------------------------------- /lib/oloop_ocaml.mlp: -------------------------------------------------------------------------------- 1 | (* -*-tuareg-*- *) 2 | open Core.Std 3 | 4 | (* 5 | * Reexport some types from the compiler libs to enable sexp on them. 6 | *) 7 | 8 | module Location = struct 9 | type t = 10 | Location.t = { 11 | loc_start: Source_code_position.t; 12 | loc_end: Source_code_position.t; 13 | loc_ghost: bool; 14 | } with sexp 15 | end 16 | 17 | module Lexer = struct 18 | type error = 19 | Lexer.error = 20 | | Illegal_character of char 21 | | Illegal_escape of string 22 | | Unterminated_comment of Location.t 23 | | Unterminated_string 24 | #if OCAML_VERSION >= (4, 02, 0) 25 | | Unterminated_string_in_comment of Location.t * Location.t 26 | #else 27 | | Unterminated_string_in_comment of Location.t 28 | #endif 29 | | Keyword_as_label of string 30 | | Literal_overflow of string 31 | with sexp 32 | end 33 | 34 | module Syntaxerr = struct 35 | type error = 36 | Syntaxerr.error = 37 | | Unclosed of Location.t * string * Location.t * string 38 | | Expecting of Location.t * string 39 | #if OCAML_VERSION >= (4, 02, 0) 40 | | Not_expecting of Location.t * string 41 | #endif 42 | | Applicative_path of Location.t 43 | | Variable_in_scope of Location.t * string 44 | | Other of Location.t 45 | #if OCAML_VERSION >= (4, 02, 0) 46 | | Ill_formed_ast of Location.t * string 47 | #endif 48 | with sexp 49 | end 50 | 51 | module Primitive = struct 52 | type description = 53 | Primitive.description = 54 | { prim_name: string; 55 | prim_arity: int; 56 | prim_alloc: bool; 57 | prim_native_name: string; 58 | prim_native_float: bool 59 | } with sexp 60 | end 61 | 62 | module Ident = struct 63 | type t = Ident.t = 64 | { stamp: int; name: string; mutable flags: int } with sexp 65 | end 66 | 67 | module Longident = struct 68 | type t = 69 | Longident.t = 70 | Lident of string 71 | | Ldot of t * string 72 | | Lapply of t * t 73 | with sexp 74 | end 75 | 76 | module Path = struct 77 | type t = 78 | Path.t = 79 | | Pident of Ident.t 80 | | Pdot of t * string * int 81 | | Papply of t * t 82 | with sexp 83 | end 84 | 85 | module Asttypes = struct 86 | type constant = 87 | Asttypes.constant = 88 | Const_int of int 89 | | Const_char of char 90 | #if OCAML_VERSION >= (4, 02, 0) 91 | | Const_string of string * string option 92 | #else 93 | | Const_string of string 94 | #endif 95 | | Const_float of string 96 | | Const_int32 of int32 97 | | Const_int64 of int64 98 | | Const_nativeint of nativeint 99 | with sexp 100 | 101 | type rec_flag = 102 | Asttypes.rec_flag = 103 | | Nonrecursive 104 | | Recursive 105 | #if OCAML_VERSION < (4, 02, 0) 106 | | Default 107 | #endif 108 | with sexp 109 | 110 | type direction_flag = Asttypes.direction_flag = Upto | Downto with sexp 111 | 112 | type private_flag = Asttypes.private_flag = Private | Public with sexp 113 | 114 | type mutable_flag = Asttypes.mutable_flag = Immutable | Mutable with sexp 115 | 116 | type virtual_flag = Asttypes.virtual_flag = Virtual | Concrete with sexp 117 | 118 | type override_flag = Asttypes.override_flag = Override | Fresh with sexp 119 | 120 | type closed_flag = Asttypes.closed_flag = Closed | Open with sexp 121 | 122 | type label = string with sexp 123 | 124 | #if OCAML_VERSION >= (4, 03, 0) 125 | type arg_label = 126 | Asttypes.arg_label = 127 | Nolabel 128 | | Labelled of string (* label:T -> ... *) 129 | | Optional of string (* ?label:T -> ... *) 130 | with sexp 131 | #endif 132 | 133 | type 'a loc = 'a Asttypes.loc = { 134 | txt : 'a; 135 | loc : Location.t; 136 | } with sexp 137 | 138 | #if OCAML_VERSION >= (4, 02, 0) 139 | type variance = 140 | Asttypes.variance = 141 | | Covariant 142 | | Contravariant 143 | | Invariant 144 | with sexp 145 | #endif 146 | end 147 | 148 | module Parsetree = struct 149 | open Asttypes 150 | 151 | #if OCAML_VERSION >= (4, 02, 0) 152 | type attribute = string loc * payload 153 | and extension = string loc * payload 154 | and attributes = attribute list 155 | and payload = Parsetree.payload = 156 | | PStr of structure 157 | | PTyp of core_type 158 | | PPat of pattern * expression option 159 | and core_type = 160 | #else 161 | type core_type = 162 | #endif 163 | Parsetree.core_type = 164 | { 165 | ptyp_desc: core_type_desc; 166 | ptyp_loc: Location.t; 167 | #if OCAML_VERSION >= (4, 02, 0) 168 | ptyp_attributes: attributes; 169 | #endif 170 | } 171 | and core_type_desc = 172 | Parsetree.core_type_desc = 173 | | Ptyp_any 174 | | Ptyp_var of string 175 | | Ptyp_arrow of label * core_type * core_type 176 | | Ptyp_tuple of core_type list 177 | | Ptyp_constr of Longident.t loc * core_type list 178 | #if OCAML_VERSION >= (4, 02, 0) 179 | | Ptyp_object of (string * attributes * core_type) list * closed_flag 180 | | Ptyp_class of Longident.t loc * core_type list 181 | #else 182 | | Ptyp_object of core_field_type list 183 | | Ptyp_class of Longident.t loc * core_type list * label list 184 | #endif 185 | | Ptyp_alias of core_type * string 186 | #if OCAML_VERSION >= (4, 02, 0) 187 | | Ptyp_variant of row_field list * closed_flag * label list option 188 | #else 189 | | Ptyp_variant of row_field list * bool * label list option 190 | #endif 191 | | Ptyp_poly of string list * core_type 192 | | Ptyp_package of package_type 193 | #if OCAML_VERSION >= (4, 02, 0) 194 | | Ptyp_extension of extension 195 | #endif 196 | and package_type = 197 | Longident.t loc * (Longident.t loc * core_type) list 198 | #if OCAML_VERSION < (4, 02, 0) 199 | and core_field_type = 200 | Parsetree.core_field_type = 201 | { pfield_desc: core_field_desc; 202 | pfield_loc: Location.t } 203 | and core_field_desc = 204 | Parsetree.core_field_desc = 205 | | Pfield of string * core_type 206 | | Pfield_var 207 | #endif 208 | and row_field = 209 | Parsetree.row_field = 210 | #if OCAML_VERSION >= (4, 02, 0) 211 | | Rtag of label * attributes * bool * core_type list 212 | #else 213 | | Rtag of label * bool * core_type list 214 | #endif 215 | | Rinherit of core_type 216 | and pattern = 217 | Parsetree.pattern = 218 | { 219 | ppat_desc: pattern_desc; 220 | ppat_loc: Location.t; 221 | #if OCAML_VERSION >= (4, 02, 0) 222 | ppat_attributes: attributes; (* ... [@id1] [@id2] *) 223 | #endif 224 | } 225 | and pattern_desc = 226 | Parsetree.pattern_desc = 227 | | Ppat_any 228 | | Ppat_var of string loc 229 | | Ppat_alias of pattern * string loc 230 | | Ppat_constant of constant 231 | #if OCAML_VERSION >= (4, 02, 0) 232 | | Ppat_interval of constant * constant 233 | #endif 234 | | Ppat_tuple of pattern list 235 | #if OCAML_VERSION >= (4, 02, 0) 236 | | Ppat_construct of Longident.t loc * pattern option 237 | #else 238 | | Ppat_construct of Longident.t loc * pattern option * bool 239 | #endif 240 | | Ppat_variant of label * pattern option 241 | | Ppat_record of (Longident.t loc * pattern) list * closed_flag 242 | | Ppat_array of pattern list 243 | | Ppat_or of pattern * pattern 244 | | Ppat_constraint of pattern * core_type 245 | | Ppat_type of Longident.t loc 246 | | Ppat_lazy of pattern 247 | | Ppat_unpack of string loc 248 | #if OCAML_VERSION >= (4, 02, 0) 249 | | Ppat_exception of pattern 250 | | Ppat_extension of extension 251 | #endif 252 | (* Value expressions *) 253 | and expression = 254 | Parsetree.expression = 255 | { 256 | pexp_desc: expression_desc; 257 | pexp_loc: Location.t; 258 | #if OCAML_VERSION >= (4, 02, 0) 259 | pexp_attributes: attributes; (* ... [@id1] [@id2] *) 260 | #endif 261 | } 262 | and expression_desc = 263 | Parsetree.expression_desc = 264 | | Pexp_ident of Longident.t loc 265 | | Pexp_constant of constant 266 | #if OCAML_VERSION >= (4, 02, 0) 267 | | Pexp_let of rec_flag * value_binding list * expression 268 | | Pexp_function of case list 269 | | Pexp_fun of label * expression option * pattern * expression 270 | #else 271 | | Pexp_let of rec_flag * (pattern * expression) list * expression 272 | | Pexp_function of label * expression option * (pattern * expression) list 273 | #endif 274 | | Pexp_apply of expression * (label * expression) list 275 | #if OCAML_VERSION >= (4, 02, 0) 276 | | Pexp_match of expression * case list 277 | | Pexp_try of expression * case list 278 | #else 279 | | Pexp_match of expression * (pattern * expression) list 280 | | Pexp_try of expression * (pattern * expression) list 281 | #endif 282 | | Pexp_tuple of expression list 283 | #if OCAML_VERSION >= (4, 02, 0) 284 | | Pexp_construct of Longident.t loc * expression option 285 | #else 286 | | Pexp_construct of Longident.t loc * expression option * bool 287 | #endif 288 | | Pexp_variant of label * expression option 289 | | Pexp_record of (Longident.t loc * expression) list * expression option 290 | | Pexp_field of expression * Longident.t loc 291 | | Pexp_setfield of expression * Longident.t loc * expression 292 | | Pexp_array of expression list 293 | | Pexp_ifthenelse of expression * expression * expression option 294 | | Pexp_sequence of expression * expression 295 | | Pexp_while of expression * expression 296 | #if OCAML_VERSION >= (4, 02, 0) 297 | | Pexp_for of 298 | pattern * expression * expression * direction_flag * expression 299 | | Pexp_constraint of expression * core_type 300 | | Pexp_coerce of expression * core_type option * core_type 301 | #else 302 | | Pexp_for of 303 | string loc * expression * expression * direction_flag * expression 304 | | Pexp_constraint of expression * core_type option * core_type option 305 | | Pexp_when of expression * expression 306 | #endif 307 | | Pexp_send of expression * string 308 | | Pexp_new of Longident.t loc 309 | | Pexp_setinstvar of string loc * expression 310 | | Pexp_override of (string loc * expression) list 311 | | Pexp_letmodule of string loc * module_expr * expression 312 | | Pexp_assert of expression 313 | #if OCAML_VERSION < (4, 02, 0) 314 | | Pexp_assertfalse 315 | #endif 316 | | Pexp_lazy of expression 317 | | Pexp_poly of expression * core_type option 318 | | Pexp_object of class_structure 319 | | Pexp_newtype of string * expression 320 | | Pexp_pack of module_expr 321 | | Pexp_open of override_flag * Longident.t loc * expression 322 | #if OCAML_VERSION >= (4, 02, 0) 323 | | Pexp_extension of extension 324 | and case = 325 | Parsetree.case = 326 | { 327 | pc_lhs: pattern; 328 | pc_guard: expression option; 329 | pc_rhs: expression; 330 | } 331 | #endif 332 | (* Value descriptions *) 333 | and value_description = 334 | Parsetree.value_description = 335 | { 336 | #if OCAML_VERSION >= (4, 02, 0) 337 | pval_name: string loc; 338 | #endif 339 | pval_type: core_type; 340 | pval_prim: string list; 341 | #if OCAML_VERSION >= (4, 02, 0) 342 | pval_attributes: attributes; 343 | #endif 344 | pval_loc: Location.t; 345 | } 346 | (* Type declarations *) 347 | and type_declaration = 348 | Parsetree.type_declaration = 349 | { 350 | #if OCAML_VERSION >= (4, 02, 0) 351 | ptype_name: string loc; 352 | ptype_params: (core_type * variance) list; 353 | #else 354 | ptype_params: string loc option list; 355 | #endif 356 | ptype_cstrs: (core_type * core_type * Location.t) list; 357 | ptype_kind: type_kind; 358 | ptype_private: private_flag; 359 | ptype_manifest: core_type option; 360 | #if OCAML_VERSION >= (4, 02, 0) 361 | ptype_attributes: attributes; 362 | #else 363 | ptype_variance: (bool * bool) list; 364 | #endif 365 | ptype_loc: Location.t; 366 | } 367 | #if OCAML_VERSION >= (4, 02, 0) 368 | and type_kind = 369 | Parsetree.type_kind = 370 | | Ptype_abstract 371 | | Ptype_variant of constructor_declaration list 372 | | Ptype_record of label_declaration list 373 | | Ptype_open 374 | and label_declaration = 375 | Parsetree.label_declaration = 376 | { 377 | pld_name: string loc; 378 | pld_mutable: mutable_flag; 379 | pld_type: core_type; 380 | pld_loc: Location.t; 381 | pld_attributes: attributes; (* l [@id1] [@id2] : T *) 382 | } 383 | and constructor_declaration = 384 | Parsetree.constructor_declaration = 385 | { 386 | pcd_name: string loc; 387 | pcd_args: core_type list; 388 | pcd_res: core_type option; 389 | pcd_loc: Location.t; 390 | pcd_attributes: attributes; (* C [@id1] [@id2] of ... *) 391 | } 392 | and type_extension = 393 | Parsetree.type_extension = 394 | { 395 | ptyext_path: Longident.t loc; 396 | ptyext_params: (core_type * variance) list; 397 | ptyext_constructors: extension_constructor list; 398 | ptyext_private: private_flag; 399 | ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) 400 | } 401 | and extension_constructor = 402 | Parsetree.extension_constructor = 403 | { 404 | pext_name: string loc; 405 | pext_kind : extension_constructor_kind; 406 | pext_loc : Location.t; 407 | pext_attributes: attributes; (* C [@id1] [@id2] of ... *) 408 | } 409 | and extension_constructor_kind = 410 | Parsetree.extension_constructor_kind = 411 | Pext_decl of core_type list * core_type option 412 | | Pext_rebind of Longident.t loc 413 | #else 414 | and type_kind = 415 | Parsetree.type_kind = 416 | Ptype_abstract 417 | | Ptype_variant of 418 | (string loc * core_type list * core_type option * Location.t) list 419 | | Ptype_record of 420 | (string loc * mutable_flag * core_type * Location.t) list 421 | and exception_declaration = core_type list 422 | #endif 423 | (** {2 Class language} *) 424 | and class_type = 425 | Parsetree.class_type = 426 | { 427 | pcty_desc: class_type_desc; 428 | pcty_loc: Location.t; 429 | #if OCAML_VERSION >= (4, 02, 0) 430 | pcty_attributes: attributes; (* ... [@id1] [@id2] *) 431 | #endif 432 | } 433 | and class_type_desc = 434 | Parsetree.class_type_desc = 435 | | Pcty_constr of Longident.t loc * core_type list 436 | | Pcty_signature of class_signature 437 | #if OCAML_VERSION >= (4, 02, 0) 438 | | Pcty_arrow of label * core_type * class_type 439 | | Pcty_extension of extension 440 | #else 441 | | Pcty_fun of label * core_type * class_type 442 | #endif 443 | and class_signature = 444 | Parsetree.class_signature = 445 | { 446 | pcsig_self: core_type; 447 | pcsig_fields: class_type_field list; 448 | #if OCAML_VERSION < (4, 02, 0) 449 | pcsig_loc: Location.t; 450 | #endif 451 | } 452 | and class_type_field = 453 | Parsetree.class_type_field = 454 | { 455 | pctf_desc: class_type_field_desc; 456 | pctf_loc: Location.t; 457 | #if OCAML_VERSION >= (4, 02, 0) 458 | pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) 459 | #endif 460 | } 461 | and class_type_field_desc = 462 | Parsetree.class_type_field_desc = 463 | #if OCAML_VERSION >= (4, 02, 0) 464 | | Pctf_inherit of class_type 465 | | Pctf_val of (string * mutable_flag * virtual_flag * core_type) 466 | | Pctf_method of (string * private_flag * virtual_flag * core_type) 467 | | Pctf_constraint of (core_type * core_type) 468 | | Pctf_attribute of attribute 469 | | Pctf_extension of extension 470 | #else 471 | | Pctf_inher of class_type 472 | | Pctf_val of (string * mutable_flag * virtual_flag * core_type) 473 | | Pctf_virt of (string * private_flag * core_type) 474 | | Pctf_meth of (string * private_flag * core_type) 475 | | Pctf_cstr of (core_type * core_type) 476 | #endif 477 | and 'a class_infos = 478 | 'a Parsetree.class_infos = 479 | { 480 | pci_virt: virtual_flag; 481 | #if OCAML_VERSION >= (4, 02, 0) 482 | pci_params: (core_type * variance) list; 483 | #else 484 | pci_params: string loc list * Location.t; 485 | #endif 486 | pci_name: string loc; 487 | pci_expr: 'a; 488 | #if OCAML_VERSION < (4, 02, 0) 489 | pci_variance: (bool * bool) list; 490 | #endif 491 | pci_loc: Location.t; 492 | #if OCAML_VERSION >= (4, 02, 0) 493 | pci_attributes: attributes; (* ... [@@id1] [@@id2] *) 494 | #endif 495 | } 496 | and class_description = class_type class_infos 497 | and class_type_declaration = class_type class_infos 498 | and class_expr = 499 | Parsetree.class_expr = 500 | { 501 | pcl_desc: class_expr_desc; 502 | pcl_loc: Location.t; 503 | #if OCAML_VERSION >= (4, 02, 0) 504 | pcl_attributes: attributes; (* ... [@id1] [@id2] *) 505 | #endif 506 | } 507 | and class_expr_desc = 508 | Parsetree.class_expr_desc = 509 | | Pcl_constr of Longident.t loc * core_type list 510 | | Pcl_structure of class_structure 511 | | Pcl_fun of label * expression option * pattern * class_expr 512 | | Pcl_apply of class_expr * (label * expression) list 513 | #if OCAML_VERSION >= (4, 02, 0) 514 | | Pcl_let of rec_flag * value_binding list * class_expr 515 | #else 516 | | Pcl_let of rec_flag * (pattern * expression) list * class_expr 517 | #endif 518 | | Pcl_constraint of class_expr * class_type 519 | #if OCAML_VERSION >= (4, 02, 0) 520 | | Pcl_extension of extension 521 | #endif 522 | and class_structure = 523 | Parsetree.class_structure = 524 | { 525 | #if OCAML_VERSION >= (4, 02, 0) 526 | pcstr_self: pattern; 527 | #else 528 | pcstr_pat: pattern; 529 | #endif 530 | pcstr_fields: class_field list; 531 | } 532 | and class_field = 533 | Parsetree.class_field = 534 | { 535 | pcf_desc: class_field_desc; 536 | pcf_loc: Location.t; 537 | #if OCAML_VERSION >= (4, 02, 0) 538 | pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) 539 | #endif 540 | } 541 | #if OCAML_VERSION >= (4, 02, 0) 542 | and class_field_desc = 543 | Parsetree.class_field_desc = 544 | | Pcf_inherit of override_flag * class_expr * string option 545 | | Pcf_val of (string loc * mutable_flag * class_field_kind) 546 | | Pcf_method of (string loc * private_flag * class_field_kind) 547 | | Pcf_constraint of (core_type * core_type) 548 | | Pcf_initializer of expression 549 | | Pcf_attribute of attribute 550 | | Pcf_extension of extension 551 | and class_field_kind = 552 | Parsetree.class_field_kind = 553 | | Cfk_virtual of core_type 554 | | Cfk_concrete of override_flag * expression 555 | #else 556 | and class_field_desc = 557 | Parsetree.class_field_desc = 558 | Pcf_inher of override_flag * class_expr * string option 559 | | Pcf_valvirt of (string loc * mutable_flag * core_type) 560 | | Pcf_val of (string loc * mutable_flag * override_flag * expression) 561 | | Pcf_virt of (string loc * private_flag * core_type) 562 | | Pcf_meth of (string loc * private_flag * override_flag * expression) 563 | | Pcf_constr of (core_type * core_type) 564 | | Pcf_init of expression 565 | #endif 566 | and class_declaration = class_expr class_infos 567 | (** {2 Module language} *) 568 | and module_type = 569 | Parsetree.module_type = 570 | { 571 | pmty_desc: module_type_desc; 572 | pmty_loc: Location.t; 573 | #if OCAML_VERSION >= (4, 02, 0) 574 | pmty_attributes: attributes; (* ... [@id1] [@id2] *) 575 | #endif 576 | } 577 | and module_type_desc = 578 | Parsetree.module_type_desc = 579 | | Pmty_ident of Longident.t loc 580 | | Pmty_signature of signature 581 | #if OCAML_VERSION >= (4, 02, 0) 582 | | Pmty_functor of string loc * module_type option * module_type 583 | | Pmty_with of module_type * with_constraint list 584 | #else 585 | | Pmty_functor of string loc * module_type * module_type 586 | | Pmty_with of module_type * (Longident.t loc * with_constraint) list 587 | #endif 588 | | Pmty_typeof of module_expr 589 | #if OCAML_VERSION >= (4, 02, 0) 590 | | Pmty_extension of extension 591 | | Pmty_alias of Longident.t loc 592 | #endif 593 | and signature = signature_item list 594 | and signature_item = 595 | Parsetree.signature_item = 596 | { 597 | psig_desc: signature_item_desc; 598 | psig_loc: Location.t; 599 | } 600 | #if OCAML_VERSION >= (4, 02, 0) 601 | and signature_item_desc = 602 | Parsetree.signature_item_desc = 603 | | Psig_value of value_description 604 | | Psig_type of type_declaration list 605 | | Psig_typext of type_extension 606 | | Psig_exception of extension_constructor 607 | | Psig_module of module_declaration 608 | | Psig_recmodule of module_declaration list 609 | | Psig_modtype of module_type_declaration 610 | | Psig_open of open_description 611 | | Psig_include of include_description 612 | | Psig_class of class_description list 613 | | Psig_class_type of class_type_declaration list 614 | | Psig_attribute of attribute 615 | | Psig_extension of extension * attributes 616 | and module_declaration = 617 | Parsetree.module_declaration = 618 | { 619 | pmd_name: string loc; 620 | pmd_type: module_type; 621 | pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) 622 | pmd_loc: Location.t; 623 | } 624 | and module_type_declaration = 625 | Parsetree.module_type_declaration = 626 | { 627 | pmtd_name: string loc; 628 | pmtd_type: module_type option; 629 | pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) 630 | pmtd_loc: Location.t; 631 | } 632 | and open_description = 633 | Parsetree.open_description = 634 | { 635 | popen_lid: Longident.t loc; 636 | popen_override: override_flag; 637 | popen_loc: Location.t; 638 | popen_attributes: attributes; 639 | } 640 | and 'a include_infos = 641 | 'a Parsetree.include_infos = 642 | { 643 | pincl_mod: 'a; 644 | pincl_loc: Location.t; 645 | pincl_attributes: attributes; 646 | } 647 | and include_description = module_type include_infos 648 | and include_declaration = module_expr include_infos 649 | and with_constraint = 650 | Parsetree.with_constraint = 651 | | Pwith_type of Longident.t loc * type_declaration 652 | | Pwith_module of Longident.t loc * Longident.t loc 653 | | Pwith_typesubst of type_declaration 654 | | Pwith_modsubst of string loc * Longident.t loc 655 | #else 656 | and signature_item_desc = 657 | Parsetree.signature_item_desc = 658 | Psig_value of string loc * value_description 659 | | Psig_type of (string loc * type_declaration) list 660 | | Psig_exception of string loc * exception_declaration 661 | | Psig_module of string loc * module_type 662 | | Psig_recmodule of (string loc * module_type) list 663 | | Psig_modtype of string loc * modtype_declaration 664 | | Psig_open of override_flag * Longident.t loc 665 | | Psig_include of module_type 666 | | Psig_class of class_description list 667 | | Psig_class_type of class_type_declaration list 668 | and modtype_declaration = 669 | Parsetree.modtype_declaration = 670 | Pmodtype_abstract 671 | | Pmodtype_manifest of module_type 672 | and with_constraint = 673 | Parsetree.with_constraint = 674 | Pwith_type of type_declaration 675 | | Pwith_module of Longident.t loc 676 | | Pwith_typesubst of type_declaration 677 | | Pwith_modsubst of Longident.t loc 678 | #endif 679 | (* Value expressions for the module language *) 680 | and module_expr = 681 | Parsetree.module_expr = 682 | { 683 | pmod_desc: module_expr_desc; 684 | pmod_loc: Location.t; 685 | #if OCAML_VERSION >= (4, 02, 0) 686 | pmod_attributes: attributes; (* ... [@id1] [@id2] *) 687 | #endif 688 | } 689 | and module_expr_desc = 690 | Parsetree.module_expr_desc = 691 | | Pmod_ident of Longident.t loc 692 | | Pmod_structure of structure 693 | #if OCAML_VERSION >= (4, 02, 0) 694 | | Pmod_functor of string loc * module_type option * module_expr 695 | #else 696 | | Pmod_functor of string loc * module_type * module_expr 697 | #endif 698 | | Pmod_apply of module_expr * module_expr 699 | | Pmod_constraint of module_expr * module_type 700 | | Pmod_unpack of expression 701 | #if OCAML_VERSION >= (4, 02, 0) 702 | | Pmod_extension of extension 703 | #endif 704 | and structure = structure_item list 705 | and structure_item = 706 | Parsetree.structure_item = 707 | { 708 | pstr_desc: structure_item_desc; 709 | pstr_loc: Location.t; 710 | } 711 | #if OCAML_VERSION >= (4, 02, 0) 712 | and structure_item_desc = 713 | Parsetree.structure_item_desc = 714 | | Pstr_eval of expression * attributes 715 | | Pstr_value of rec_flag * value_binding list 716 | | Pstr_primitive of value_description 717 | | Pstr_type of type_declaration list 718 | | Pstr_typext of type_extension 719 | | Pstr_exception of extension_constructor 720 | | Pstr_module of module_binding 721 | | Pstr_recmodule of module_binding list 722 | | Pstr_modtype of module_type_declaration 723 | | Pstr_open of open_description 724 | | Pstr_class of class_declaration list 725 | | Pstr_class_type of class_type_declaration list 726 | | Pstr_include of include_declaration 727 | | Pstr_attribute of attribute 728 | | Pstr_extension of extension * attributes 729 | and value_binding = 730 | Parsetree.value_binding = 731 | { 732 | pvb_pat: pattern; 733 | pvb_expr: expression; 734 | pvb_attributes: attributes; 735 | pvb_loc: Location.t; 736 | } 737 | and module_binding = 738 | Parsetree.module_binding = 739 | { 740 | pmb_name: string loc; 741 | pmb_expr: module_expr; 742 | pmb_attributes: attributes; 743 | pmb_loc: Location.t; 744 | } 745 | #else 746 | and structure_item_desc = 747 | Parsetree.structure_item_desc = 748 | Pstr_eval of expression 749 | | Pstr_value of rec_flag * (pattern * expression) list 750 | | Pstr_primitive of string loc * value_description 751 | | Pstr_type of (string loc * type_declaration) list 752 | | Pstr_exception of string loc * exception_declaration 753 | | Pstr_exn_rebind of string loc * Longident.t loc 754 | | Pstr_module of string loc * module_expr 755 | | Pstr_recmodule of (string loc * module_type * module_expr) list 756 | | Pstr_modtype of string loc * module_type 757 | | Pstr_open of override_flag * Longident.t loc 758 | | Pstr_class of class_declaration list 759 | | Pstr_class_type of class_type_declaration list 760 | | Pstr_include of module_expr 761 | #endif 762 | with sexp 763 | end 764 | 765 | module Types = struct 766 | open Asttypes 767 | 768 | type type_expr = 769 | Types.type_expr = 770 | { mutable desc: type_desc; 771 | mutable level: int; 772 | mutable id: int } 773 | 774 | and type_desc = 775 | Types.type_desc = 776 | Tvar of string option 777 | | Tarrow of string * type_expr * type_expr * commutable 778 | | Ttuple of type_expr list 779 | | Tconstr of Path.t * type_expr list * abbrev_memo ref 780 | | Tobject of type_expr * (Path.t * type_expr list) option ref 781 | | Tfield of string * field_kind * type_expr * type_expr 782 | | Tnil 783 | | Tlink of type_expr 784 | | Tsubst of type_expr (* for copying *) 785 | | Tvariant of row_desc 786 | | Tunivar of string option 787 | | Tpoly of type_expr * type_expr list 788 | | Tpackage of Path.t * Longident.t list * type_expr list 789 | 790 | and row_desc = 791 | Types.row_desc = 792 | { row_fields: (string * row_field) list; 793 | row_more: type_expr; 794 | row_bound: unit; (* kept for compatibility *) 795 | row_closed: bool; 796 | row_fixed: bool; 797 | row_name: (Path.t * type_expr list) option } 798 | 799 | and row_field = 800 | Types.row_field = 801 | | Rpresent of type_expr option 802 | | Reither of bool * type_expr list * bool * row_field option ref 803 | (* 1st true denotes a constant constructor *) 804 | (* 2nd true denotes a tag in a pattern matching, and 805 | is erased later *) 806 | | Rabsent 807 | 808 | and abbrev_memo = 809 | Types.abbrev_memo = 810 | Mnil 811 | | Mcons of private_flag * Path.t 812 | * type_expr * type_expr * abbrev_memo 813 | | Mlink of abbrev_memo ref 814 | 815 | and field_kind = 816 | Types.field_kind = 817 | Fvar of field_kind option ref 818 | | Fpresent 819 | | Fabsent 820 | 821 | and commutable = 822 | Types.commutable = 823 | Cok 824 | | Cunknown 825 | | Clink of commutable ref 826 | with sexp 827 | 828 | module Meths = struct 829 | type 'a t = 'a Types.Meths.t 830 | 831 | let sexp_of_t (f: 'a -> Sexp.t) (m: 'a t) = 832 | let add_sexp k v l = Sexp.List [Sexp.Atom k; f v] :: l in 833 | Sexp.List(Types.Meths.fold add_sexp m []) 834 | 835 | let t_of_sexp (f: Sexp.t -> 'a) = function 836 | | Sexp.List l -> 837 | let add (m: 'a t) = function 838 | | Sexp.List [Sexp.Atom k; v] -> Types.Meths.add k (f v) m 839 | | _ -> failwith "Oloop: Types.Meths: incorrect sexp" in 840 | List.fold l ~init:Types.Meths.empty ~f:add 841 | | Sexp.Atom _ -> failwith "Oloop: Types.Meths: incorrect sexp" 842 | end 843 | 844 | module Vars = struct 845 | type 'a t = 'a Types.Vars.t 846 | 847 | let sexp_of_t (f: 'a -> Sexp.t) (m: 'a t) = 848 | let add_sexp k v l = Sexp.List [Sexp.Atom k; f v] :: l in 849 | Sexp.List(Types.Vars.fold add_sexp m []) 850 | 851 | let t_of_sexp (f: Sexp.t -> 'a) = function 852 | | Sexp.List l -> 853 | let add (m: 'a t) = function 854 | | Sexp.List [Sexp.Atom k; v] -> Types.Vars.add k (f v) m 855 | | _ -> failwith "Oloop: Types.Cars: incorrect sexp" in 856 | List.fold l ~init:Types.Vars.empty ~f:add 857 | | Sexp.Atom _ -> failwith "Oloop: Types.Vars: incorrect sexp" 858 | end 859 | 860 | type value_description = 861 | Types.value_description = 862 | { val_type: type_expr; (* Type of the value *) 863 | val_kind: value_kind; 864 | val_loc: Location.t; 865 | #if OCAML_VERSION >= (4, 02, 0) 866 | val_attributes: Parsetree.attributes; 867 | #endif 868 | } 869 | 870 | and value_kind = 871 | Types.value_kind = 872 | | Val_reg (* Regular value *) 873 | | Val_prim of Primitive.description (* Primitive *) 874 | | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) 875 | | Val_self of (Ident.t * type_expr) Meths.t ref * 876 | (Ident.t * mutable_flag * virtual_flag 877 | * type_expr) Vars.t ref * string * type_expr 878 | (* Self *) 879 | | Val_anc of (string * Ident.t) list * string (* Ancestor *) 880 | | Val_unbound (* Unbound variable *) 881 | with sexp 882 | 883 | type label_description = 884 | Types.label_description = 885 | { lbl_name: string; 886 | lbl_res: type_expr; 887 | lbl_arg: type_expr; 888 | lbl_mut: mutable_flag; 889 | lbl_pos: int; 890 | lbl_all: label_description array; 891 | lbl_repres: record_representation; 892 | lbl_private: private_flag; 893 | #if OCAML_VERSION >= (4, 02, 0) 894 | lbl_loc: Location.t; 895 | lbl_attributes: Parsetree.attributes; 896 | #endif 897 | } 898 | and record_representation = 899 | Types.record_representation = 900 | Record_regular 901 | | Record_float 902 | with sexp 903 | 904 | module Variance = struct 905 | type t = Types.Variance.t 906 | 907 | (* FIXME: Variance.t is abstract and does not offer enough 908 | functions to deconstruct and reconstruct it. We use the 909 | fact that we know its internal representation is an [int]. *) 910 | let t_of_sexp : Sexplib.Sexp.t -> t = fun sexp -> 911 | (Obj.magic (int_of_sexp sexp) : t) 912 | let sexp_of_t : t -> Sexplib.Sexp.t = fun t -> 913 | sexp_of_int(Obj.magic t) 914 | ;; 915 | end 916 | 917 | type type_declaration = 918 | Types.type_declaration = 919 | { type_params: type_expr list; 920 | type_arity: int; 921 | type_kind: type_kind; 922 | type_private: private_flag; 923 | type_manifest: type_expr option; 924 | type_variance: Variance.t list; 925 | (* covariant, contravariant, weakly contravariant, injective *) 926 | type_newtype_level: (int * int) option; 927 | (* definition level * expansion level *) 928 | type_loc: Location.t; 929 | #if OCAML_VERSION >= (4, 02, 0) 930 | type_attributes: Parsetree.attributes; 931 | #endif 932 | } 933 | 934 | #if OCAML_VERSION >= (4, 02, 0) 935 | and type_kind = 936 | Types.type_kind = 937 | Type_abstract 938 | | Type_record of label_declaration list * record_representation 939 | | Type_variant of constructor_declaration list 940 | | Type_open 941 | and label_declaration = 942 | Types.label_declaration = 943 | { 944 | ld_id: Ident.t; 945 | ld_mutable: mutable_flag; 946 | ld_type: type_expr; 947 | ld_loc: Location.t; 948 | ld_attributes: Parsetree.attributes; 949 | } 950 | and constructor_declaration = 951 | Types.constructor_declaration = 952 | { 953 | cd_id: Ident.t; 954 | cd_args: type_expr list; 955 | cd_res: type_expr option; 956 | cd_loc: Location.t; 957 | cd_attributes: Parsetree.attributes; 958 | } 959 | and extension_constructor = 960 | Types.extension_constructor = 961 | { 962 | ext_type_path: Path.t; 963 | ext_type_params: type_expr list; 964 | ext_args: type_expr list; 965 | ext_ret_type: type_expr option; 966 | ext_private: private_flag; 967 | ext_loc: Location.t; 968 | ext_attributes: Parsetree.attributes; 969 | } 970 | #else 971 | and type_kind = 972 | Types.type_kind = 973 | Type_abstract 974 | | Type_record of 975 | (Ident.t * mutable_flag * type_expr) list * record_representation 976 | | Type_variant of (Ident.t * type_expr list * type_expr option) list 977 | and exception_declaration = 978 | Types.exception_declaration = 979 | { exn_args: type_expr list; 980 | exn_loc: Location.t } 981 | #endif 982 | and type_transparence = 983 | Types.type_transparence = 984 | Type_public (* unrestricted expansion *) 985 | | Type_new (* "new" type *) 986 | | Type_private (* private type *) 987 | with sexp 988 | 989 | module Concr = struct 990 | type t = Types.Concr.t 991 | 992 | let sexp_of_t (set: t) = 993 | Sexp.List(Types.Concr.fold (fun v l -> Sexp.Atom v :: l) set []) 994 | 995 | let t_of_sexp = function 996 | | Sexp.List l -> 997 | let add (set: t) = function 998 | | Sexp.Atom v -> Types.Concr.add v set 999 | | Sexp.List _ -> failwith "Oloop: Types.Meths: incorrect sexp" in 1000 | List.fold l ~init:Types.Concr.empty ~f:add 1001 | | Sexp.Atom _ -> failwith "Oloop: Types.Concr: incorrect sexp" 1002 | end 1003 | 1004 | type class_type = 1005 | Types.class_type = 1006 | | Cty_constr of Path.t * type_expr list * class_type 1007 | | Cty_signature of class_signature 1008 | #if OCAML_VERSION >= (4, 02, 0) 1009 | | Cty_arrow of label * type_expr * class_type 1010 | #else 1011 | | Cty_fun of label * type_expr * class_type 1012 | #endif 1013 | and class_signature = 1014 | Types.class_signature = { 1015 | #if OCAML_VERSION >= (4, 02, 0) 1016 | csig_self: type_expr; 1017 | csig_vars: 1018 | (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; 1019 | csig_concr: Concr.t; 1020 | csig_inher: (Path.t * type_expr list) list 1021 | #else 1022 | cty_self: type_expr; 1023 | cty_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; 1024 | cty_concr: Concr.t; 1025 | cty_inher: (Path.t * type_expr list) list 1026 | #endif 1027 | } with sexp 1028 | 1029 | type class_declaration = 1030 | Types.class_declaration = 1031 | { cty_params: type_expr list; 1032 | mutable cty_type: class_type; 1033 | cty_path: Path.t; 1034 | cty_new: type_expr option; 1035 | cty_variance: Variance.t list; 1036 | #if OCAML_VERSION >= (4, 02, 0) 1037 | cty_loc: Location.t; 1038 | cty_attributes: Parsetree.attributes; 1039 | #endif 1040 | } with sexp 1041 | 1042 | type class_type_declaration = 1043 | Types.class_type_declaration = 1044 | { clty_params: type_expr list; 1045 | clty_type: class_type; 1046 | clty_path: Path.t; 1047 | clty_variance: Variance.t list; 1048 | #if OCAML_VERSION >= (4, 02, 0) 1049 | clty_loc: Location.t; 1050 | clty_attributes: Parsetree.attributes; 1051 | #endif 1052 | } with sexp 1053 | 1054 | 1055 | type module_type = 1056 | Types.module_type = 1057 | | Mty_ident of Path.t 1058 | | Mty_signature of signature 1059 | #if OCAML_VERSION >= (4, 02, 0) 1060 | | Mty_functor of Ident.t * module_type option * module_type 1061 | | Mty_alias of Path.t 1062 | #else 1063 | | Mty_functor of Ident.t * module_type * module_type 1064 | #endif 1065 | and signature = signature_item list 1066 | 1067 | and signature_item = 1068 | Types.signature_item = 1069 | | Sig_value of Ident.t * value_description 1070 | | Sig_type of Ident.t * type_declaration * rec_status 1071 | #if OCAML_VERSION >= (4, 02, 0) 1072 | | Sig_typext of Ident.t * extension_constructor * ext_status 1073 | | Sig_module of Ident.t * module_declaration * rec_status 1074 | #else 1075 | | Sig_exception of Ident.t * exception_declaration 1076 | | Sig_module of Ident.t * module_type * rec_status 1077 | #endif 1078 | | Sig_modtype of Ident.t * modtype_declaration 1079 | | Sig_class of Ident.t * class_declaration * rec_status 1080 | | Sig_class_type of Ident.t * class_type_declaration * rec_status 1081 | 1082 | #if OCAML_VERSION >= (4, 02, 0) 1083 | and module_declaration = 1084 | Types.module_declaration = 1085 | { 1086 | md_type: module_type; 1087 | md_attributes: Parsetree.attributes; 1088 | md_loc: Location.t; 1089 | } 1090 | 1091 | and modtype_declaration = 1092 | Types.modtype_declaration = 1093 | { 1094 | mtd_type: module_type option; (* None: abstract *) 1095 | mtd_attributes: Parsetree.attributes; 1096 | mtd_loc: Location.t; 1097 | } 1098 | #else 1099 | and modtype_declaration = 1100 | Types.modtype_declaration = 1101 | | Modtype_abstract 1102 | | Modtype_manifest of module_type 1103 | #endif 1104 | and rec_status = 1105 | Types.rec_status = 1106 | | Trec_not 1107 | | Trec_first 1108 | | Trec_next 1109 | 1110 | #if OCAML_VERSION >= (4, 02, 0) 1111 | and ext_status = 1112 | Types.ext_status = 1113 | | Text_first 1114 | | Text_next 1115 | | Text_exception 1116 | #endif 1117 | with sexp 1118 | end 1119 | 1120 | module Includecore = struct 1121 | type type_mismatch = 1122 | Includecore.type_mismatch = 1123 | Arity 1124 | | Privacy 1125 | | Kind 1126 | | Constraint 1127 | | Manifest 1128 | | Variance 1129 | | Field_type of Ident.t 1130 | | Field_mutable of Ident.t 1131 | | Field_arity of Ident.t 1132 | | Field_names of int * Ident.t * Ident.t 1133 | | Field_missing of bool * Ident.t 1134 | | Record_representation of bool 1135 | with sexp 1136 | end 1137 | 1138 | module Env = struct 1139 | open Types 1140 | 1141 | type t = Env.t 1142 | (* The compiler type is abstract and may contain closures. We 1143 | replace environments by empty ones. *) 1144 | 1145 | type summary = 1146 | Env.summary = 1147 | | Env_empty 1148 | | Env_value of summary * Ident.t * value_description 1149 | | Env_type of summary * Ident.t * type_declaration 1150 | #if OCAML_VERSION >= (4, 02, 0) 1151 | | Env_extension of summary * Ident.t * extension_constructor 1152 | | Env_module of summary * Ident.t * module_declaration 1153 | #else 1154 | | Env_exception of summary * Ident.t * exception_declaration 1155 | | Env_module of summary * Ident.t * module_type 1156 | #endif 1157 | | Env_modtype of summary * Ident.t * modtype_declaration 1158 | | Env_class of summary * Ident.t * class_declaration 1159 | | Env_cltype of summary * Ident.t * class_type_declaration 1160 | | Env_open of summary * Path.t 1161 | #if OCAML_VERSION >= (4, 02, 0) 1162 | | Env_functor_arg of summary * Ident.t 1163 | #endif 1164 | with sexp 1165 | 1166 | let initial_environment = 1167 | Compmisc.init_path false; (* false because the toploop is not native *) 1168 | Compmisc.initial_env() 1169 | 1170 | let of_summary sum = 1171 | try 1172 | (* Do the same as Envaux.env_of_only_summary except that it 1173 | uses [sum] as the summary (one cannot set directly the 1174 | summary of a given environment). *) 1175 | let env_from_summary _sum subst = 1176 | Envaux.env_from_summary sum subst in 1177 | Env.env_of_only_summary env_from_summary initial_environment 1178 | with _ -> 1179 | (* FIXME: do we want to report the error? *) 1180 | Env.empty 1181 | 1182 | let t_of_sexp sexp = 1183 | of_summary(summary_of_sexp sexp) 1184 | 1185 | let sexp_of_t t = 1186 | sexp_of_summary(Env.summary t) 1187 | end 1188 | 1189 | module Typedecl = struct 1190 | open Types 1191 | 1192 | type error = 1193 | Typedecl.error = 1194 | | Repeated_parameter 1195 | | Duplicate_constructor of string 1196 | | Too_many_constructors 1197 | | Duplicate_label of string 1198 | | Recursive_abbrev of string 1199 | #if OCAML_VERSION >= (4, 02, 0) 1200 | | Cycle_in_def of string * type_expr 1201 | #endif 1202 | | Definition_mismatch of type_expr * Includecore.type_mismatch list 1203 | | Constraint_failed of type_expr * type_expr 1204 | | Inconsistent_constraint of Env.t * (type_expr * type_expr) list 1205 | | Type_clash of Env.t * (type_expr * type_expr) list 1206 | | Parameters_differ of Path.t * type_expr * type_expr 1207 | | Null_arity_external 1208 | | Missing_native_external 1209 | | Unbound_type_var of type_expr * type_declaration 1210 | #if OCAML_VERSION >= (4, 02, 0) 1211 | | Not_open_type of Path.t 1212 | | Not_extensible_type of Path.t 1213 | | Extension_mismatch of Path.t * Includecore.type_mismatch list 1214 | | Rebind_wrong_type of Longident.t * Env.t * (type_expr * type_expr) list 1215 | | Rebind_mismatch of Longident.t * Path.t * Path.t 1216 | | Rebind_private of Longident.t 1217 | #else 1218 | | Unbound_exception of Longident.t 1219 | | Not_an_exception of Longident.t 1220 | #endif 1221 | | Bad_variance of int * (bool*bool*bool) * (bool*bool*bool) 1222 | | Unavailable_type_constructor of Path.t 1223 | | Bad_fixed_type of string 1224 | #if OCAML_VERSION >= (4, 02, 0) 1225 | | Unbound_type_var_ext of type_expr * extension_constructor 1226 | #else 1227 | | Unbound_type_var_exc of type_expr * type_expr 1228 | #endif 1229 | | Varying_anonymous 1230 | with sexp 1231 | end 1232 | 1233 | module Typetexp = struct 1234 | open Types 1235 | 1236 | type error = 1237 | Typetexp.error = 1238 | Unbound_type_variable of string 1239 | | Unbound_type_constructor of Longident.t 1240 | | Unbound_type_constructor_2 of Path.t 1241 | | Type_arity_mismatch of Longident.t * int * int 1242 | | Bound_type_variable of string 1243 | | Recursive_type 1244 | | Unbound_row_variable of Longident.t 1245 | | Type_mismatch of (type_expr * type_expr) list 1246 | | Alias_type_mismatch of (type_expr * type_expr) list 1247 | | Present_has_conjunction of string 1248 | | Present_has_no_type of string 1249 | | Constructor_mismatch of type_expr * type_expr 1250 | | Not_a_variant of type_expr 1251 | | Variant_tags of string * string 1252 | | Invalid_variable_name of string 1253 | | Cannot_quantify of string * type_expr 1254 | | Multiple_constraints_on_type of Longident.t 1255 | | Repeated_method_label of string 1256 | | Unbound_value of Longident.t 1257 | | Unbound_constructor of Longident.t 1258 | | Unbound_label of Longident.t 1259 | | Unbound_module of Longident.t 1260 | | Unbound_class of Longident.t 1261 | | Unbound_modtype of Longident.t 1262 | | Unbound_cltype of Longident.t 1263 | | Ill_typed_functor_application of Longident.t 1264 | | Illegal_reference_to_recursive_module 1265 | #if OCAML_VERSION >= (4, 02, 0) 1266 | | Access_functor_as_structure of Longident.t 1267 | #endif 1268 | with sexp 1269 | end 1270 | 1271 | module Typecore = struct 1272 | open Asttypes 1273 | open Types 1274 | 1275 | type error = 1276 | Typecore.error = 1277 | Polymorphic_label of Longident.t 1278 | | Constructor_arity_mismatch of Longident.t * int * int 1279 | | Label_mismatch of Longident.t * (type_expr * type_expr) list 1280 | | Pattern_type_clash of (type_expr * type_expr) list 1281 | #if OCAML_VERSION >= (4, 02, 0) 1282 | | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list 1283 | #endif 1284 | | Multiply_bound_variable of string 1285 | | Orpat_vars of Ident.t 1286 | | Expr_type_clash of (type_expr * type_expr) list 1287 | | Apply_non_function of type_expr 1288 | | Apply_wrong_label of label * type_expr 1289 | | Label_multiply_defined of string 1290 | | Label_missing of Ident.t list 1291 | | Label_not_mutable of Longident.t 1292 | #if OCAML_VERSION >= (4, 02, 0) 1293 | | Wrong_name of string * type_expr * string * Path.t * Longident.t 1294 | #else 1295 | | Wrong_name of string * Path.t * Longident.t 1296 | #endif 1297 | | Name_type_mismatch of 1298 | string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list 1299 | #if OCAML_VERSION >= (4, 02, 0) 1300 | | Invalid_format of string 1301 | #else 1302 | | Incomplete_format of string 1303 | | Bad_conversion of string * int * char 1304 | #endif 1305 | | Undefined_method of type_expr * string 1306 | | Undefined_inherited_method of string 1307 | | Virtual_class of Longident.t 1308 | | Private_type of type_expr 1309 | | Private_label of Longident.t * type_expr 1310 | | Unbound_instance_variable of string 1311 | | Instance_variable_not_mutable of bool * string 1312 | | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list 1313 | | Outside_class 1314 | | Value_multiply_overridden of string 1315 | | Coercion_failure of 1316 | type_expr * type_expr * (type_expr * type_expr) list * bool 1317 | | Too_many_arguments of bool * type_expr 1318 | | Abstract_wrong_label of label * type_expr 1319 | | Scoping_let_module of string * type_expr 1320 | | Masked_instance_variable of Longident.t 1321 | | Not_a_variant_type of Longident.t 1322 | | Incoherent_label_order 1323 | | Less_general of string * (type_expr * type_expr) list 1324 | | Modules_not_allowed 1325 | | Cannot_infer_signature 1326 | | Not_a_packed_module of type_expr 1327 | | Recursive_local_constraint of (type_expr * type_expr) list 1328 | | Unexpected_existential 1329 | | Unqualified_gadt_pattern of Path.t * string 1330 | #if OCAML_VERSION >= (4, 02, 0) 1331 | | Invalid_interval 1332 | | Invalid_for_loop_index 1333 | | No_value_clauses 1334 | | Exception_pattern_below_toplevel 1335 | #endif 1336 | with sexp 1337 | end 1338 | 1339 | module Ctype = struct 1340 | open Types 1341 | 1342 | type class_match_failure = 1343 | Ctype.class_match_failure = 1344 | CM_Virtual_class 1345 | | CM_Parameter_arity_mismatch of int * int 1346 | | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list 1347 | | CM_Class_type_mismatch of Env.t * class_type * class_type 1348 | | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list 1349 | | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list 1350 | | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list 1351 | | CM_Non_mutable_value of string 1352 | | CM_Non_concrete_value of string 1353 | | CM_Missing_value of string 1354 | | CM_Missing_method of string 1355 | | CM_Hide_public of string 1356 | | CM_Hide_virtual of string * string 1357 | | CM_Public_method of string 1358 | | CM_Private_method of string 1359 | | CM_Virtual_method of string 1360 | with sexp 1361 | 1362 | type closed_class_failure = 1363 | Ctype.closed_class_failure = 1364 | | CC_Method of type_expr * bool * string * type_expr 1365 | | CC_Value of type_expr * bool * string * type_expr 1366 | with sexp 1367 | end 1368 | 1369 | 1370 | module Typeclass = struct 1371 | open Asttypes 1372 | open Types 1373 | 1374 | type error = 1375 | Typeclass.error = 1376 | | Unconsistent_constraint of (type_expr * type_expr) list 1377 | | Field_type_mismatch of string * string * (type_expr * type_expr) list 1378 | | Structure_expected of class_type 1379 | | Cannot_apply of class_type 1380 | #if OCAML_VERSION >= (4, 03, 0) 1381 | | Apply_wrong_label of arg_label 1382 | #else 1383 | | Apply_wrong_label of label 1384 | #endif 1385 | | Pattern_type_clash of type_expr 1386 | | Repeated_parameter 1387 | | Unbound_class_2 of Longident.t 1388 | | Unbound_class_type_2 of Longident.t 1389 | | Abbrev_type_clash of type_expr * type_expr * type_expr 1390 | | Constructor_type_mismatch of string * (type_expr * type_expr) list 1391 | #if OCAML_VERSION <= (4, 01, 0) 1392 | | Virtual_class of bool * string list * string list 1393 | #else 1394 | | Virtual_class of bool * bool * string list * string list 1395 | #endif 1396 | | Parameter_arity_mismatch of Longident.t * int * int 1397 | | Parameter_mismatch of (type_expr * type_expr) list 1398 | | Bad_parameters of Ident.t * type_expr * type_expr 1399 | | Class_match_failure of Ctype.class_match_failure list 1400 | | Unbound_val of string 1401 | | Unbound_type_var of (Format.formatter -> unit) 1402 | * Ctype.closed_class_failure 1403 | | Make_nongen_seltype of type_expr 1404 | | Non_generalizable_class of Ident.t * Types.class_declaration 1405 | | Cannot_coerce_self of type_expr 1406 | | Non_collapsable_conjunction of 1407 | Ident.t * Types.class_declaration * (type_expr * type_expr) list 1408 | | Final_self_clash of (type_expr * type_expr) list 1409 | | Mutability_mismatch of string * mutable_flag 1410 | | No_overriding of string * string 1411 | | Duplicate of string * string 1412 | with sexp 1413 | 1414 | end 1415 | 1416 | module Symtable = struct 1417 | type error = 1418 | Symtable.error = 1419 | Undefined_global of string 1420 | | Unavailable_primitive of string 1421 | | Wrong_vm of string 1422 | | Uninitialized_global of string 1423 | with sexp 1424 | end 1425 | 1426 | 1427 | 1428 | (*** Suppress values beginning with _. Lifted straight from uTop: 1429 | * uTop_main.ml 1430 | * ------------ 1431 | * Copyright : (c) 2011, Jeremie Dimino 1432 | * Licence : BSD3 1433 | **) 1434 | 1435 | let rec map_items (unwrap: 'a -> Outcometree.out_sig_item * 'b) 1436 | (wrap: Outcometree.out_sig_item -> 'b -> 'a) 1437 | (items: 'a list) : 'a list = 1438 | match items with 1439 | | [] -> 1440 | [] 1441 | | item :: items -> 1442 | let sig_item, _ = unwrap item in 1443 | let name, _rec_status = 1444 | match sig_item with 1445 | | Outcometree.Osig_class (_, name, _, _, rs) 1446 | | Outcometree.Osig_class_type (_, name, _, _, rs) 1447 | | Outcometree.Osig_module (name, _, rs) 1448 | #if OCAML_VERSION >= (4, 02, 0) 1449 | | Outcometree.Osig_type ({ Outcometree.otype_name = name; _ }, rs) -> 1450 | #else 1451 | | Outcometree.Osig_type ((name, _, _, _, _), rs) -> 1452 | #endif 1453 | (name, rs) 1454 | #if OCAML_VERSION >= (4, 02, 0) 1455 | | Outcometree.Osig_typext ({ Outcometree.oext_name = name; _ }, _) 1456 | #else 1457 | | Outcometree.Osig_exception (name, _) 1458 | #endif 1459 | | Outcometree.Osig_modtype (name, _) 1460 | | Outcometree.Osig_value (name, _, _) -> 1461 | (name, Outcometree.Orec_not) 1462 | #if OCAML_VERSION >= (4, 03, 0) 1463 | | Outcometree.Osig_ellipsis -> ("", Outcometree.Orec_not) 1464 | #endif 1465 | in 1466 | let keep = name = "" || name.[0] <> '_' in 1467 | if keep then 1468 | item :: map_items unwrap wrap items 1469 | else 1470 | (* Replace the [Orec_next] at the head of items by [Orec_first] *) 1471 | let items = 1472 | match items with 1473 | | [] -> 1474 | [] 1475 | | item :: items' -> 1476 | let sig_item, extra = unwrap item in 1477 | match sig_item with 1478 | | Outcometree.Osig_class (a, name, b, c, rs) -> 1479 | if rs = Outcometree.Orec_next then 1480 | wrap (Outcometree.Osig_class 1481 | (a, name, b, c, Outcometree.Orec_first)) extra 1482 | :: items' 1483 | else 1484 | items 1485 | | Outcometree.Osig_class_type (a, name, b, c, rs) -> 1486 | if rs = Outcometree.Orec_next then 1487 | wrap (Outcometree.Osig_class_type 1488 | (a, name, b, c, Outcometree.Orec_first)) extra 1489 | :: items' 1490 | else 1491 | items 1492 | | Outcometree.Osig_module (name, a, rs) -> 1493 | if rs = Outcometree.Orec_next then 1494 | wrap (Outcometree.Osig_module 1495 | (name, a, Outcometree.Orec_first)) extra :: items' 1496 | else 1497 | items 1498 | | Outcometree.Osig_type (oty, rs) -> 1499 | if rs = Outcometree.Orec_next then 1500 | wrap (Outcometree.Osig_type 1501 | (oty, Outcometree.Orec_first)) extra :: items' 1502 | else 1503 | items 1504 | #if OCAML_VERSION >= (4, 02, 0) 1505 | | Outcometree.Osig_typext _ 1506 | #else 1507 | | Outcometree.Osig_exception _ 1508 | #endif 1509 | #if OCAML_VERSION >= (4, 03, 0) 1510 | | Outcometree.Osig_ellipsis 1511 | #endif 1512 | | Outcometree.Osig_modtype _ 1513 | | Outcometree.Osig_value _ -> 1514 | items 1515 | in 1516 | map_items unwrap wrap items 1517 | 1518 | 1519 | let signatures_remove_underscore_names 1520 | (items : Outcometree.out_sig_item list) = 1521 | map_items (fun x -> (x, ())) (fun x () -> x) items 1522 | 1523 | let phrase_remove_underscore_names (phrase:Outcometree.out_phrase) = 1524 | match phrase with 1525 | | Outcometree.Ophr_eval _ 1526 | | Outcometree.Ophr_exception _ -> phrase 1527 | | Outcometree.Ophr_signature items -> 1528 | Outcometree.Ophr_signature (map_items (fun x -> x) (fun x y -> (x, y)) items) 1529 | 1530 | (* End of uTop code *) 1531 | --------------------------------------------------------------------------------