Merge pull request #103 from diml/die-camlp4-die

Remove hard dependency on camlp4
This commit is contained in:
Peter Zotov 2014-10-20 20:07:42 +04:00
commit 11442761a0
11 changed files with 198 additions and 1175 deletions

25
_oasis
View File

@ -2,12 +2,12 @@
# | Package parameters |
# +-------------------------------------------------------------------+
OASISFormat: 0.3
OCamlVersion: >= 3.12
OASISFormat: 0.4
OCamlVersion: >= 4.01
Name: utop
Version: 1.15
LicenseFile: LICENSE
License: BSD3
License: BSD-3-clause
Authors: Jeremie Dimino
Maintainers: Jeremie Dimino <jeremie@dimino.org>
Homepage: https://github.com/diml/utop
@ -15,6 +15,8 @@ BuildTools: ocamlbuild
Plugins: DevFiles (0.3), META (0.3)
XDevFilesEnableMakefile: false
FilesAB: src/lib/uTop_version.ml.ab
AlphaFeatures: ocamlbuild_more_args
XOCamlbuildPluginTags: package(cppo_ocamlbuild)
Synopsis: Universal toplevel for OCaml
Description:
utop is an improved toplevel for OCaml. It can run in a terminal or
@ -27,12 +29,9 @@ Description:
# | The toplevel |
# +-------------------------------------------------------------------+
Library "optcomp"
Install: false
Path: syntax
Modules: Pa_optcomp
BuildDepends: camlp4, camlp4.quotations.o
CompiledObject: byte
Flag camlp4
Description: camlp4 support
Default: false
Library utop
Path: src/lib
@ -46,11 +45,13 @@ Library utop
UTop_token,
UTop_complete,
UTop_styles
BuildDepends: findlib, lambda-term (>= 1.2), lwt.syntax, threads
BuildDepends: threads, findlib, lambda-term (>= 1.2)
XMETADescription: utop configuration
XMETARequires: findlib, lambda-term
Library "utop-camlp4"
Build$: flag(camlp4)
Install$: flag(camlp4)
FindlibName: camlp4
FindlibParent: utop
Path: src/camlp4
@ -64,7 +65,7 @@ Executable utop
Path: src/top
CompiledObject: byte
MainIs: uTop_top.ml
BuildDepends: utop, findlib, lambda-term, lwt.syntax, threads
BuildDepends: threads, findlib, lambda-term, utop
DataFiles: utop.el ($datadir/emacs/site-lisp)
Executable "utop-full"
@ -72,7 +73,7 @@ Executable "utop-full"
Path: src/top
CompiledObject: byte
MainIs: uTop_top_full.ml
BuildDepends: utop, findlib, lambda-term, lwt.syntax, threads
BuildDepends: threads, findlib, lambda-term, utop
DataFiles: utop.el ($datadir/emacs/site-lisp)
# +-------------------------------------------------------------------+

8
_tags
View File

@ -1,13 +1,7 @@
# -*- conf -*-
# Use camlp4 on all files
<**/*.ml>: syntax_camlp4o, pkg_lwt.syntax, pa_optcomp
# Do not use optcomp on syntax extensions
<syntax/*.ml>: -pa_optcomp
# Use compiler interfaces
<src/**/*.ml{,i}>: use_compiler_libs
<src/**/*.ml{,i}>: package(compiler-libs)
# Use camlp5
<src/camlp5/**/*.ml{,i}>: use_camlp5

View File

@ -14,6 +14,7 @@ let () =
dispatch
(fun hook ->
dispatch_default hook;
Ocamlbuild_cppo.dispatcher hook;
match hook with
| Before_options ->
Options.make_links := false
@ -31,30 +32,16 @@ let () =
flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg";
let env = BaseEnvLight.load () in
let path = BaseEnvLight.var_get "compiler_libs" env in
let stdlib = BaseEnvLight.var_get "standard_library" env in
let findlib_version = BaseEnvLight.var_get "findlib_version" env in
let findlib_version =
Scanf.sscanf findlib_version "%d.%d" (Printf.sprintf "findlib_version=(%d, %d)")
let ocaml_version =
Scanf.sscanf Sys.ocaml_version "%d.%d.%d" (fun major minor patchlevel ->
(* e.g. #define OCAML_VERSION 040201 *)
Printf.sprintf "OCAML_VERSION %d" (major * 10000 + minor * 100 + patchlevel))
in
(* Optcomp *)
let args =
S[A"-ppopt"; A"syntax/pa_optcomp.cmo";
A"-ppopt"; A"-let"; A"-ppopt"; A findlib_version]
in
flag ["ocaml"; "compile"; "pa_optcomp"] args;
flag ["ocaml"; "ocamldep"; "pa_optcomp"] args;
flag ["ocaml"; "doc"; "pa_optcomp"] args;
dep ["ocaml"; "ocamldep"; "pa_optcomp"] ["syntax/pa_optcomp.cmo"];
(* Add directories for compiler-libraries: *)
let paths = List.filter Sys.file_exists [path; path / "typing"; path / "parsing"; path / "utils"] in
let paths = List.map (fun path -> S [A "-I"; A path]) paths in
flag ["ocaml"; "compile"; "use_compiler_libs"] & S paths;
flag ["ocaml"; "ocamldep"; "use_compiler_libs"] & S paths;
flag ["ocaml"; "doc"; "use_compiler_libs"] & S paths;
(* Cppo *)
flag ["cppo"] & S[A"-D"; A ocaml_version];
let paths = [A "-I"; A "+camlp5"] in
flag ["ocaml"; "compile"; "use_camlp5"] & S paths;
@ -70,8 +57,8 @@ let () =
let packages =
Tags.fold
(fun tag packages ->
if String.is_prefix "pkg_" tag && not (String.is_suffix tag ".syntax") then
String.after tag 4 :: packages
if String.is_prefix "package(" tag then
String.sub tag 8 (String.length tag - 9) :: packages
else
packages)
(tags_of_pathname "src/top/uTop_top.byte")

14
opam
View File

@ -4,17 +4,21 @@ authors: ["Jérémie Dimino"]
homepage: "https://github.com/diml/utop"
license: "BSD3"
build: [
["./configure" "--prefix" prefix]
["./configure" "--prefix" prefix "--%{camlp4:enable}%-camlp4"]
[make]
[make "install"]
]
build-doc: [["ocaml" "setup.ml" "-doc"]]
remove: [["ocamlfind" "remove" "utop"]]
depends: [
"ocamlfind"
"ocamlfind" {>= "1.4.0"}
"lambda-term" {>= "1.2"}
"lwt"
"react" {>= "1.0.0"}
"oasis" {>= "0.3.0"}
"react" {>= "1.0.0"}
"cppo" {>= "1.0.1"}
"oasis" {>= "0.3.0"}
]
ocaml-version: [>= "3.12"]
depopts: [
"camlp4"
]
available: [ ocaml-version >= "4.01" ]

View File

@ -13,7 +13,7 @@ open Camlp4.PreCast
module Ast2pt = Camlp4.Struct.Camlp4Ast2OCamlAst.Make(Ast)
#if ocaml_version < (4, 2, 0)
#if OCAML_VERSION < 040200
external cast_toplevel_phrase : Camlp4_import.Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase = "%identity"
#else
let cast_toplevel_phrase x = x

View File

@ -1,3 +0,0 @@
(* Must be the same as driver/errors.mli from ocaml sources. *)
open Format
val report_error : formatter -> exn -> unit

View File

@ -13,6 +13,8 @@ open LTerm_text
open LTerm_geom
open LTerm_style
let (>>=) = Lwt.(>>=)
module String_set = Set.Make(String)
let version = UTop_version.version
@ -122,25 +124,26 @@ let collect_formatters buf pps f =
(* First flush all formatters. *)
List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
(* Save all formatter functions. *)
let save = List.map (fun pp -> Format.pp_get_all_formatter_output_functions pp ()) pps in
let save = List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in
let restore () =
List.iter2
(fun pp (out, flush, newline, spaces) ->
(fun pp out_functions ->
Format.pp_print_flush pp ();
Format.pp_set_all_formatter_output_functions pp ~out ~flush ~newline ~spaces)
Format.pp_set_formatter_out_functions pp out_functions)
pps save
in
(* Output functions. *)
let out str ofs len = Buffer.add_substring buf str ofs len in
let flush = ignore in
let newline () = Buffer.add_char buf '\n' in
let spaces n = for i = 1 to n do Buffer.add_char buf ' ' done in
let out_string str ofs len = Buffer.add_substring buf str ofs len
and out_flush = ignore
and out_newline () = Buffer.add_char buf '\n'
and out_spaces n = for i = 1 to n do Buffer.add_char buf ' ' done in
let out_functions = { Format.out_string; out_flush; out_newline; out_spaces } in
(* Replace formatter functions. *)
let cols = (S.value size).cols in
List.iter
(fun pp ->
Format.pp_set_margin pp cols;
Format.pp_set_all_formatter_output_functions pp ~out ~flush ~newline ~spaces)
Format.pp_set_formatter_out_functions pp out_functions)
pps;
try
let x = f () in
@ -154,21 +157,21 @@ let discard_formatters pps f =
(* First flush all formatters. *)
List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
(* Save all formatter functions. *)
let save = List.map (fun pp -> Format.pp_get_all_formatter_output_functions pp ()) pps in
let save = List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in
let restore () =
List.iter2
(fun pp (out, flush, newline, spaces) ->
(fun pp out_functions ->
Format.pp_print_flush pp ();
Format.pp_set_all_formatter_output_functions pp ~out ~flush ~newline ~spaces)
Format.pp_set_formatter_out_functions pp out_functions)
pps save
in
(* Output functions. *)
let out str ofs len = () in
let flush = ignore in
let newline = ignore in
let spaces = ignore in
let out_functions = {
Format.out_string = (fun _ _ _ -> ()); out_flush = ignore;
out_newline = ignore; out_spaces = ignore;
} in
(* Replace formatter functions. *)
List.iter (fun pp -> Format.pp_set_all_formatter_output_functions pp ~out ~flush ~newline ~spaces) pps;
List.iter (fun pp -> Format.pp_set_formatter_out_functions pp out_functions) pps;
try
let x = f () in
restore ();
@ -189,11 +192,7 @@ type 'a result =
exception Need_more
#if ocaml_version <= (3, 12, 1)
let input_name = ""
#else
let input_name = "//toplevel//"
#endif
let lexbuf_of_string eof str =
let pos = ref 0 in
@ -244,15 +243,13 @@ let parse_default parse str eos_is_error =
| Syntaxerr.Other loc ->
Error ([mkloc loc],
"Syntax error")
#if ocaml_version >= (4, 01, 0)
| Syntaxerr.Expecting (loc, nonterm) ->
Error ([mkloc loc],
Printf.sprintf "Syntax error: %s expected." nonterm)
| Syntaxerr.Variable_in_scope (loc, var) ->
Error ([mkloc loc],
Printf.sprintf "In this scoped type, variable '%s is reserved for the local type %s." var var)
#endif
#if ocaml_version >= (4, 2, 0)
#if OCAML_VERSION >= 040200
| Syntaxerr.Not_expecting (loc, nonterm) ->
Error ([mkloc loc],
Printf.sprintf "Syntax error: %s not expected" nonterm)
@ -286,14 +283,10 @@ let rec last head tail =
| head :: tail ->
last head tail
#if ocaml_version >= (4, 0, 0)
let with_loc loc str = {
Location.txt = str;
Location.loc = loc;
}
#else
let with_loc loc str = str
#endif
(* Check that the given phrase can be evaluated without typing/compile
errors. *)
@ -316,7 +309,7 @@ let check_phrase phrase =
(* Construct "let _ () = let module _ = struct <items> end in ()" in order to test
the typing and compilation of [items] without evaluating them. *)
let unit = with_loc loc (Longident.Lident "()") in
#if ocaml_version < (4, 2, 0)
#if OCAML_VERSION < 040200
let structure = {
pmod_loc = loc;
pmod_desc = Pmod_structure (item :: items);
@ -359,9 +352,7 @@ let check_phrase phrase =
try
let _ =
discard_formatters [Format.err_formatter] (fun () ->
#if ocaml_version > (4, 00, 1)
Env.reset_cache_toplevel ();
#endif
Toploop.execute_phrase false null check_phrase)
in
(* The phrase is safe. *)
@ -595,10 +586,10 @@ For a complete description of utop, look at the utop(1) manual page."));
+-----------------------------------------------------------------+ *)
let print_error msg =
lwt term = Lazy.force LTerm.stdout in
lwt () = LTerm.set_style term !UTop_private.error_style in
lwt () = Lwt_io.print msg in
lwt () = LTerm.set_style term LTerm_style.none in
Lazy.force LTerm.stdout >>= fun term ->
LTerm.set_style term !UTop_private.error_style >>= fun () ->
Lwt_io.print msg >>= fun () ->
LTerm.set_style term LTerm_style.none >>= fun () ->
LTerm.flush term
let handle_findlib_error = function
@ -611,6 +602,14 @@ let handle_findlib_error = function
| exn ->
raise exn
let check_for_camlp4_support () =
try
ignore (Fl_package_base.query "utop.camlp4");
true
with Fl_package_base.No_such_package("utop.camlp4", "") ->
Lwt_main.run (print_error "utop was built without camlp4 support.\n");
false
let set_syntax syntax =
match get_syntax (), syntax with
| Normal, Normal
@ -619,25 +618,21 @@ let set_syntax syntax =
()
| (Camlp4o | Camlp4r), _ ->
Lwt_main.run (print_error "Camlp4 already loaded, you cannot change the syntax now.\n")
| Normal, Camlp4o -> begin
set_syntax Camlp4o;
set_phrase_terminator ";;";
try
| Normal, Camlp4o ->
if check_for_camlp4_support () then begin
Topfind.syntax "camlp4o";
Topfind.load_deeply ["utop.camlp4"]
with exn ->
handle_findlib_error exn
end
| Normal, Camlp4r -> begin
set_syntax Camlp4r;
set_phrase_terminator ";";
add_keyword "value";
try
Topfind.load_deeply ["utop.camlp4"];
set_syntax Camlp4o;
set_phrase_terminator ";;"
end
| Normal, Camlp4r ->
if check_for_camlp4_support () then begin
Topfind.syntax "camlp4r";
Topfind.load_deeply ["utop.camlp4"]
with exn ->
handle_findlib_error exn
end
Topfind.load_deeply ["utop.camlp4"];
set_syntax Camlp4r;
set_phrase_terminator ";";
add_keyword "value"
end
let () =
Hashtbl.add
@ -658,13 +653,11 @@ let () =
let topfind_log, set_topfind_log = S.create ~eq:(fun _ _ -> false) []
#if findlib_version >= (1, 4)
let () =
let real_log = !Topfind.log in
Topfind.log := fun str ->
set_topfind_log (str :: S.value topfind_log);
if S.value topfind_verbose then real_log str
#endif
let () =
Hashtbl.add

View File

@ -302,7 +302,7 @@ let list_directories dir =
String_set.empty
(try Sys.readdir (if dir = "" then Filename.current_dir_name else dir) with Sys_error _ -> [||]))
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
let path () =
let path_separator =
match Sys.os_type with
@ -394,12 +394,9 @@ let visible_modules () =
acc)
String_set.empty !Config.load_path)
#if ocaml_version >= (4, 2, 0)
#if OCAML_VERSION >= 040200
let field_name { ld_id = id } = Ident.name id
let constructor_name { cd_id = id } = Ident.name id
#elif ocaml_version >= (4, 0, 0)
let field_name (id, _, _) = Ident.name id
let constructor_name (id, _, _) = Ident.name id
#else
let field_name (name, _, _) = name
let constructor_name (name, _) = name
@ -413,7 +410,7 @@ let add_fields_of_type decl acc =
List.fold_left (fun acc field -> add (field_name field) acc) acc fields
| Type_abstract ->
acc
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
| Type_open ->
acc
#endif
@ -426,19 +423,17 @@ let add_names_of_type decl acc =
List.fold_left (fun acc field -> add (field_name field) acc) acc fields
| Type_abstract ->
acc
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
| Type_open ->
acc
#endif
#if ocaml_version >= (4, 0, 0)
let rec names_of_module_type = function
| Mty_signature decls ->
List.fold_left
(fun acc decl -> match decl with
| Sig_value (id, _)
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
| Sig_typext (id, _, _)
#else
| Sig_exception (id, _)
@ -453,7 +448,7 @@ let rec names_of_module_type = function
String_set.empty decls
| Mty_ident path -> begin
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
#if ocaml_version < (4, 2, 0)
#if OCAML_VERSION < 040200
| Some Modtype_abstract -> String_set.empty
| Some Modtype_manifest module_type -> names_of_module_type module_type
#else
@ -462,7 +457,7 @@ let rec names_of_module_type = function
#endif
| None -> String_set.empty
end
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
| Mty_alias path -> begin
match lookup_env Env.find_module path !Toploop.toplevel_env with
| None -> String_set.empty
@ -477,7 +472,7 @@ let rec fields_of_module_type = function
List.fold_left
(fun acc decl -> match decl with
| Sig_value (id, _)
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
| Sig_typext (id, _, _)
#else
| Sig_exception (id, _)
@ -492,7 +487,7 @@ let rec fields_of_module_type = function
String_set.empty decls
| Mty_ident path -> begin
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
#if ocaml_version < (4, 2, 0)
#if OCAML_VERSION < 040200
| Some Modtype_abstract -> String_set.empty
| Some Modtype_manifest module_type -> fields_of_module_type module_type
#else
@ -501,7 +496,7 @@ let rec fields_of_module_type = function
#endif
| None -> String_set.empty
end
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
| Mty_alias path -> begin
match lookup_env Env.find_module path !Toploop.toplevel_env with
| None -> String_set.empty
@ -511,57 +506,7 @@ let rec fields_of_module_type = function
| _ ->
String_set.empty
#else
let rec names_of_module_type = function
| Tmty_signature decls ->
List.fold_left
(fun acc decl -> match decl with
| Tsig_value(id, _)
| Tsig_exception(id, _)
| Tsig_module(id, _, _)
| Tsig_modtype(id, _)
| Tsig_class(id, _, _)
| Tsig_cltype(id, _, _) ->
add (Ident.name id) acc
| Tsig_type(id, decl, _) ->
add_names_of_type decl (add (Ident.name id) acc))
String_set.empty decls
| Tmty_ident path -> begin
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
| Some Tmodtype_abstract -> String_set.empty
| Some Tmodtype_manifest module_type -> names_of_module_type module_type
| None -> String_set.empty
end
| _ ->
String_set.empty
let rec fields_of_module_type = function
| Tmty_signature decls ->
List.fold_left
(fun acc decl -> match decl with
| Tsig_value(id, _)
| Tsig_exception(id, _)
| Tsig_module(id, _, _)
| Tsig_modtype(id, _)
| Tsig_class(id, _, _)
| Tsig_cltype(id, _, _) ->
acc
| Tsig_type(id, decl, _) ->
add_fields_of_type decl acc)
String_set.empty decls
| Tmty_ident path -> begin
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
| Some Tmodtype_abstract -> String_set.empty
| Some Tmodtype_manifest module_type -> fields_of_module_type module_type
| None -> String_set.empty
end
| _ ->
String_set.empty
#endif
#if ocaml_version < (4, 2, 0)
#if OCAML_VERSION < 040200
let lookup_module = Env.lookup_module
let find_module = Env.find_module
#else
@ -606,7 +551,7 @@ let list_global_names () =
loop (add (Ident.name id) acc) summary
| Env.Env_type(summary, id, decl) ->
loop (add_names_of_type decl (add (Ident.name id) acc)) summary
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
| Env.Env_extension(summary, id, _) ->
#else
| Env.Env_exception(summary, id, _) ->
@ -620,7 +565,7 @@ let list_global_names () =
loop (add (Ident.name id) acc) summary
| Env.Env_cltype(summary, id, _) ->
loop (add (Ident.name id) acc) summary
#if ocaml_version >= (4, 2, 0)
#if OCAML_VERSION >= 040200
| Env.Env_functor_arg(summary, id) ->
loop (add (Ident.name id) acc) summary
#endif
@ -671,7 +616,7 @@ let list_global_fields () =
loop (add (Ident.name id) acc) summary
| Env.Env_type(summary, id, decl) ->
loop (add_fields_of_type decl (add (Ident.name id) acc)) summary
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
| Env.Env_extension(summary, id, _) ->
#else
| Env.Env_exception(summary, id, _) ->
@ -679,7 +624,7 @@ let list_global_fields () =
loop (add (Ident.name id) acc) summary
| Env.Env_module(summary, id, _) ->
loop (add (Ident.name id) acc) summary
#if ocaml_version >= (4, 2, 0)
#if OCAML_VERSION >= 040200
| Env.Env_functor_arg(summary, id) ->
loop (add (Ident.name id) acc) summary
#endif
@ -941,7 +886,7 @@ let complete ~syntax ~phrase_terminator ~input =
(loc.idx2 - Zed_utf8.length name,
List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\"" ^ phrase_terminator)) result)
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
(* Completion on #ppx. *)
| [(Symbol "#", _); (Lident ("ppx"), _); (String false, loc)] ->
let file = String.sub input (loc.ofs1 + 1) (String.length input - loc.ofs1 - 1) in

View File

@ -8,7 +8,6 @@
*)
open CamomileLibraryDyn.Camomile
open Lwt
open Lwt_react
open LTerm_text
open LTerm_geom
@ -16,6 +15,8 @@ open UTop_token
open UTop_styles
open UTop_private
let return, (>>=) = Lwt.return, Lwt.(>>=)
module String_set = Set.Make(String)
exception Term of int
@ -29,10 +30,14 @@ let save_history () =
| None ->
return ()
| Some fn ->
try_lwt
LTerm_history.save UTop.history ?max_size:!UTop.history_file_max_size ?max_entries:!UTop.history_file_max_entries fn
with Unix.Unix_error (error, func, arg) ->
Lwt_log.error_f "cannot save history to %S: %s: %s" fn func (Unix.error_message error)
Lwt.catch
(fun () -> LTerm_history.save UTop.history
?max_size:!UTop.history_file_max_size
?max_entries:!UTop.history_file_max_entries fn)
(function
| Unix.Unix_error (error, func, arg) ->
Lwt_log.error_f "cannot save history to %S: %s: %s" fn func (Unix.error_message error)
| exn -> Lwt.fail exn)
let init_history () =
(* Save history on exit. *)
@ -42,10 +47,13 @@ let init_history () =
| None ->
return ()
| Some fn ->
try_lwt
LTerm_history.load UTop.history fn
with Unix.Unix_error (error, func, arg) ->
Lwt_log.error_f "cannot load history from %S: %s: %s" fn func (Unix.error_message error)
Lwt.catch
(fun () -> LTerm_history.load UTop.history fn)
(function
| Unix.Unix_error (error, func, arg) ->
Lwt_log.error_f "cannot load history from %S: %s: %s"
fn func (Unix.error_message error)
| exn -> Lwt.fail exn)
(* +-----------------------------------------------------------------+
| offset --> index |
@ -89,7 +97,7 @@ let parse_and_check input eos_is_error =
let buf = Buffer.create 32 in
let preprocess input =
match input with
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
| UTop.Value (Parsetree.Ptop_def pstr) ->
begin try
let pstr = Pparse.apply_rewriters ~tool_name:"ocaml"
@ -261,13 +269,13 @@ let rec map_items unwrap wrap items =
| Outcometree.Osig_class (_, name, _, _, rs)
| Outcometree.Osig_class_type (_, name, _, _, rs)
| Outcometree.Osig_module (name, _, rs)
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
| Outcometree.Osig_type ({ Outcometree.otype_name = name }, rs) ->
#else
| Outcometree.Osig_type ((name, _, _, _, _), rs) ->
#endif
(name, rs)
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
| Outcometree.Osig_typext ({ Outcometree.oext_name = name}, _)
#else
| Outcometree.Osig_exception (name, _)
@ -308,7 +316,7 @@ let rec map_items unwrap wrap items =
wrap (Outcometree.Osig_type (oty, Outcometree.Orec_first)) extra :: items'
else
items
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
| Outcometree.Osig_typext _
#else
| Outcometree.Osig_exception _
@ -347,14 +355,10 @@ let () =
| Toplevel expression rewriting |
+-----------------------------------------------------------------+ *)
#if ocaml_version >= (4, 0, 0)
let with_loc loc str = {
Location.txt = str;
Location.loc = loc;
}
#else
let with_loc loc str = str
#endif
(* A rule for rewriting a toplevel expression. *)
type rewrite_rule = {
@ -375,7 +379,7 @@ let longident_async_thread_safe_block_on_async_exn =
Longident.parse "Async.Std.Thread_safe.block_on_async_exn"
let longident_unit = Longident.Lident "()"
#if ocaml_version < (4, 2, 0)
#if OCAML_VERSION < 040200
(* Wrap <expr> into: fun () -> <expr> *)
let wrap_unit loc e =
let i = with_loc loc longident_unit in
@ -394,7 +398,7 @@ let () =
Hashtbl.add rewrite_rules (Longident.Ldot (Longident.Lident "Lwt", "t")) {
required_values = [longident_lwt_main_run];
rewrite = (fun loc e ->
#if ocaml_version < (4, 2, 0)
#if OCAML_VERSION < 040200
{ Parsetree.pexp_desc =
Parsetree.Pexp_apply
({ Parsetree.pexp_desc = Parsetree.Pexp_ident (with_loc loc longident_lwt_main_run);
@ -416,7 +420,7 @@ let () =
let rule = {
required_values = [longident_async_thread_safe_block_on_async_exn];
rewrite = (fun loc e ->
#if ocaml_version < (4, 2, 0)
#if OCAML_VERSION < 040200
{ Parsetree.pexp_desc =
Parsetree.Pexp_apply
({ Parsetree.pexp_desc = Parsetree.Pexp_ident
@ -490,17 +494,9 @@ let is_persistent_in_env longident =
with Not_found ->
false
#if ocaml_version >= (4, 0, 0)
let str_items_of_typed_structure tstr = tstr.Typedtree.str_items
let str_desc_of_typed_str_item tstr = tstr.Typedtree.str_desc
#else
let str_items_of_typed_structure tstr = tstr
let str_desc_of_typed_str_item tstr = tstr
#endif
#if ocaml_version < (4, 2, 0)
#if OCAML_VERSION < 040200
let rewrite_str_item pstr_item tstr_item =
match pstr_item, str_desc_of_typed_str_item tstr_item with
match pstr_item, tstr_item.Typedtree.str_desc with
| ({ Parsetree.pstr_desc = Parsetree.Pstr_eval e;
Parsetree.pstr_loc = loc },
Typedtree.Tstr_eval { Typedtree.exp_type = typ }) -> begin
@ -518,7 +514,7 @@ let rewrite_str_item pstr_item tstr_item =
pstr_item
#else
let rewrite_str_item pstr_item tstr_item =
match pstr_item, str_desc_of_typed_str_item tstr_item with
match pstr_item, tstr_item.Typedtree.str_desc with
| ({ Parsetree.pstr_desc = Parsetree.Pstr_eval (e, _);
Parsetree.pstr_loc = loc },
Typedtree.Tstr_eval ({ Typedtree.exp_type = typ }, _)) -> begin
@ -541,8 +537,7 @@ let rewrite phrase =
| Parsetree.Ptop_def pstr ->
if (UTop.get_auto_run_lwt () || UTop.get_auto_run_async ()) && List.exists is_eval pstr then
let tstr, _, _ = Typemod.type_structure !Toploop.toplevel_env pstr Location.none in
let tstr = str_items_of_typed_structure tstr in
Parsetree.Ptop_def (List.map2 rewrite_str_item pstr tstr)
Parsetree.Ptop_def (List.map2 rewrite_str_item pstr tstr.Typedtree.str_items)
else
Parsetree.Ptop_def pstr
| Parsetree.Ptop_dir _ ->
@ -553,20 +548,22 @@ let rewrite phrase =
+-----------------------------------------------------------------+ *)
let rec read_phrase term =
try_lwt
(new read_phrase ~term)#run
with Sys.Break ->
lwt () = LTerm.fprintl term "Interrupted." in
read_phrase term
Lwt.catch
(fun () -> (new read_phrase ~term)#run)
(function
| Sys.Break ->
LTerm.fprintl term "Interrupted." >>= fun () ->
read_phrase term
| exn -> Lwt.fail exn)
let update_margin pp cols =
if Format.pp_get_margin pp () <> cols then
Format.pp_set_margin pp cols
let print_error term msg =
lwt () = LTerm.set_style term styles.style_error in
lwt () = Lwt_io.print msg in
lwt () = LTerm.set_style term LTerm_style.none in
LTerm.set_style term styles.style_error >>= fun () ->
Lwt_io.print msg >>= fun () ->
LTerm.set_style term LTerm_style.none >>= fun () ->
LTerm.flush term
let rec loop term =
@ -582,18 +579,18 @@ let rec loop term =
(* Read interactively user input. *)
let phrase_opt =
Lwt_main.run (
try_lwt
lwt result, warnings = read_phrase term in
(* Print warnings before errors. *)
lwt () = Lwt_io.print warnings in
match result with
| UTop.Value phrase ->
return (Some phrase)
| UTop.Error (_, msg) ->
lwt () = print_error term msg in
return None
finally
LTerm.flush term
Lwt.finalize
(fun () ->
read_phrase term >>= fun (result, warnings) ->
(* Print warnings before errors. *)
Lwt_io.print warnings >>= fun () ->
match result with
| UTop.Value phrase ->
return (Some phrase)
| UTop.Error (_, msg) ->
print_error term msg >>= fun () ->
return None)
(fun () -> LTerm.flush term)
)
in
@ -610,13 +607,9 @@ let rec loop term =
let pp = Format.formatter_of_buffer buffer in
Format.pp_set_margin pp (LTerm.size term).cols;
(try
#if ocaml_version > (4, 00, 1)
Env.reset_cache_toplevel ();
#endif
if !Clflags.dump_parsetree then Printast.top_phrase pp phrase;
#if ocaml_version > (4, 00, 1)
if !Clflags.dump_source then Pprintast.top_phrase pp phrase;
#endif
ignore (Toploop.execute_phrase true pp phrase);
(* Flush everything. *)
Format.pp_print_flush Format.std_formatter ();
@ -677,10 +670,10 @@ let welcome term =
LTerm_draw.draw_styled ctx 1 ((size.cols - String.length message) / 2) (eval [B_fg LTerm_style.yellow; S message]);
(* Render to the screen. *)
lwt () = LTerm.print_box term matrix in
LTerm.print_box term matrix >>= fun () ->
(* Move to after the box. *)
lwt () = LTerm.fprint term "\n" in
LTerm.fprint term "\n" >>= fun () ->
LTerm.flush term
@ -695,7 +688,7 @@ let read_input_classic prompt buffer len =
else
Lwt_io.read_char_opt Lwt_io.stdin >>= function
| Some c ->
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
Bytes.set buffer i c;
#else
buffer.[i] <- c;
@ -707,7 +700,7 @@ let read_input_classic prompt buffer len =
| None ->
return (i, true)
in
Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >> loop 0)
Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >>= fun () -> loop 0)
(* +-----------------------------------------------------------------+
| Emacs mode |
@ -825,7 +818,7 @@ module Emacs(M : sig end) = struct
(* Rewrite toplevel expressions. *)
let phrase = rewrite phrase in
try
#if ocaml_version > (4, 00, 1)
#if OCAML_VERSION > 040001
Env.reset_cache_toplevel ();
#endif
ignore (Toploop.execute_phrase true Format.std_formatter phrase);
@ -1012,8 +1005,6 @@ end
| Extra macros |
+-----------------------------------------------------------------+ *)
#if ocaml_version > (4, 00, 1)
let typeof sid =
let id = Longident.parse sid in
let env = !Toploop.toplevel_env in
@ -1041,7 +1032,7 @@ let typeof sid =
Some (Printtyp.tree_of_type_declaration id ty_decl Types.Trec_not)
with Not_found ->
try
#if ocaml_version < (4, 02, 0)
#if OCAML_VERSION < 040200
let (path, mod_typ) = Env.lookup_module id env in
#else
let path = Env.lookup_module id env ~load:true in
@ -1058,7 +1049,7 @@ let typeof sid =
try
let cstr_desc = Env.lookup_constructor id env in
match cstr_desc.Types.cstr_tag with
#if ocaml_version < (4, 02, 0)
#if OCAML_VERSION < 040200
| Types.Cstr_exception (_path, loc) ->
let path, exn_decl = Typedecl.transl_exn_rebind env loc id in
let id = Ident.create (Path.name path) in
@ -1083,13 +1074,10 @@ let typeof sid =
let str = Buffer.contents buf in
Lwt_main.run (Lazy.force LTerm.stdout >>= fun term -> render_out_phrase term str)
let () =
Hashtbl.add Toploop.directive_table "typeof"
(Toploop.Directive_string typeof)
#endif
(* +-----------------------------------------------------------------+
| Entry point |
+-----------------------------------------------------------------+ *)
@ -1149,9 +1137,7 @@ let print_version_num () =
let autoload = ref true
let args = Arg.align [
#if ocaml_version >= (3, 13, 0)
"-absname", Arg.Set Location.absname, " Show absolute filenames in error message";
#endif
"-I", Arg.String (fun dir -> Clflags.include_dirs := Misc.expand_directory Config.standard_library dir :: !Clflags.include_dirs), "<dir> Add <dir> to the list of include directories";
"-init", Arg.String (fun s -> Clflags.init_file := Some s), "<file> Load <file> instead of default init file";
"-labels", Arg.Clear Clflags.classic, " Use commuting label mode";
@ -1159,17 +1145,15 @@ let args = Arg.align [
"-noassert", Arg.Set Clflags.noassert, " Do not compile assertion checks";
"-nolabels", Arg.Set Clflags.classic, " Ignore non-optional labels in types";
"-nostdlib", Arg.Set Clflags.no_std_include, " Do not add default directory to the list of include directories";
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
"-ppx", Arg.String (fun ppx -> Clflags.all_ppx := ppx :: !Clflags.all_ppx), "<command> Pipe abstract syntax trees through preprocessor <command>";
#endif
"-principal", Arg.Set Clflags.principal, " Check principality of type inference";
#if ocaml_version >= (4, 02, 0)
#if OCAML_VERSION >= 040200
"-safe-string", Arg.Clear Clflags.unsafe_string, " Make strings immutable";
#endif
#if ocaml_version >= (4, 01, 0)
"-short-paths", Arg.Clear Clflags.real_paths, " Shorten paths in types (the default)";
"-no-short-paths", Arg.Set Clflags.real_paths, " Do not shorten paths in types";
#endif
"-rectypes", Arg.Set Clflags.recursive_types, " Allow arbitrary recursive types";
"-stdin", Arg.Unit (fun () -> run_script ""), " Read script from standard input";
"-strict-sequence", Arg.Set Clflags.strict_sequence, " Left-hand part of a sequence must have type unit";
@ -1203,14 +1187,10 @@ let args = Arg.align [
"-require", Arg.String (fun s -> preload := `Packages (UTop.split_words s) :: !preload),
"<package> Load this package";
"-dparsetree", Arg.Set Clflags.dump_parsetree, " Dump OCaml AST after rewriting";
#if ocaml_version > (4, 00, 1)
"-dsource", Arg.Set Clflags.dump_source, " Dump OCaml source after rewriting";
#endif
]
#if ocaml_version >= (4, 01, 0)
let () = Clflags.real_paths := false
#endif
let app_name = Filename.basename Sys.executable_name
let usage = Printf.sprintf "Usage: %s <options> <object-files> [script-file [arguments]]\noptions are:" app_name
@ -1272,13 +1252,14 @@ let common_init () =
catch Sys.sigterm
let load_inputrc () =
try_lwt
LTerm_inputrc.load ()
with
| Unix.Unix_error (error, func, arg) ->
Lwt_log.error_f "cannot load key bindings from %S: %s: %s" LTerm_inputrc.default func (Unix.error_message error)
| LTerm_inputrc.Parse_error (fname, line, msg) ->
Lwt_log.error_f "error in key bindings file %S, line %d: %s" fname line msg
Lwt.catch
LTerm_inputrc.load
(function
| Unix.Unix_error (error, func, arg) ->
Lwt_log.error_f "cannot load key bindings from %S: %s: %s" LTerm_inputrc.default func (Unix.error_message error)
| LTerm_inputrc.Parse_error (fname, line, msg) ->
Lwt_log.error_f "error in key bindings file %S, line %d: %s" fname line msg
| exn -> Lwt.fail exn)
let main_aux () =
Arg.parse args file_argument usage;
@ -1296,7 +1277,7 @@ let main_aux () =
(* Set the initial size. *)
UTop_private.set_size (S.const (LTerm.size term));
(* Load user data. *)
Lwt_main.run (join [UTop_styles.load (); load_inputrc ()]);
Lwt_main.run (Lwt.join [UTop_styles.load (); load_inputrc ()]);
(* Display a welcome message. *)
Lwt_main.run (welcome term);
(* Common initialization. *)

View File

@ -7,9 +7,10 @@
* This file is a part of utop.
*)
open Lwt
open UTop_token
let return, (>>=) = Lwt.return, Lwt.(>>=)
module String_set = Set.Make (String)
type styles = {
@ -56,41 +57,43 @@ let styles = {
let load () =
let fn = Filename.concat LTerm_resources.home ".utoprc" in
try_lwt
lwt res = LTerm_resources.load fn in
styles.style_keyword <- LTerm_resources.get_style "keyword" res;
styles.style_symbol <- LTerm_resources.get_style "symbol" res;
styles.style_ident <- LTerm_resources.get_style "identifier" res;
styles.style_module <- LTerm_resources.get_style "module" res;
styles.style_constant <- LTerm_resources.get_style "constant" res;
styles.style_char <- LTerm_resources.get_style "char" res;
styles.style_string <- LTerm_resources.get_style "string" res;
styles.style_quotation <- LTerm_resources.get_style "quotation" res;
styles.style_comment <- LTerm_resources.get_style "comment" res;
styles.style_doc <- LTerm_resources.get_style "doc" res;
styles.style_blanks <- LTerm_resources.get_style "blanks" res;
styles.style_error <- LTerm_resources.get_style "error" res;
styles.style_directive <- LTerm_resources.get_style "directive" res;
styles.style_paren <- LTerm_resources.get_style "parenthesis" res;
styles.style_font <- (match LTerm_resources.get "font" res with
| "" -> None
| str -> Some str);
styles.style_foreground <- LTerm_resources.get_color "foreground" res;
styles.style_background <- LTerm_resources.get_color "background" res;
styles.style_cursor <- LTerm_resources.get_color "cursor" res;
(match String.lowercase (LTerm_resources.get "profile" res) with
| "light" -> UTop.set_profile UTop.Light
| "dark" -> UTop.set_profile UTop.Dark
| "" -> ()
| str -> raise (LTerm_resources.Error (Printf.sprintf "invalid profile %S" str)));
UTop_private.error_style := styles.style_error;
UTop_private.autoload := LTerm_resources.get_bool "autoload" res <> Some false;
return ()
with
Lwt.catch
(fun () ->
LTerm_resources.load fn >>= fun res ->
styles.style_keyword <- LTerm_resources.get_style "keyword" res;
styles.style_symbol <- LTerm_resources.get_style "symbol" res;
styles.style_ident <- LTerm_resources.get_style "identifier" res;
styles.style_module <- LTerm_resources.get_style "module" res;
styles.style_constant <- LTerm_resources.get_style "constant" res;
styles.style_char <- LTerm_resources.get_style "char" res;
styles.style_string <- LTerm_resources.get_style "string" res;
styles.style_quotation <- LTerm_resources.get_style "quotation" res;
styles.style_comment <- LTerm_resources.get_style "comment" res;
styles.style_doc <- LTerm_resources.get_style "doc" res;
styles.style_blanks <- LTerm_resources.get_style "blanks" res;
styles.style_error <- LTerm_resources.get_style "error" res;
styles.style_directive <- LTerm_resources.get_style "directive" res;
styles.style_paren <- LTerm_resources.get_style "parenthesis" res;
styles.style_font <- (match LTerm_resources.get "font" res with
| "" -> None
| str -> Some str);
styles.style_foreground <- LTerm_resources.get_color "foreground" res;
styles.style_background <- LTerm_resources.get_color "background" res;
styles.style_cursor <- LTerm_resources.get_color "cursor" res;
(match String.lowercase (LTerm_resources.get "profile" res) with
| "light" -> UTop.set_profile UTop.Light
| "dark" -> UTop.set_profile UTop.Dark
| "" -> ()
| str -> raise (LTerm_resources.Error (Printf.sprintf "invalid profile %S" str)));
UTop_private.error_style := styles.style_error;
UTop_private.autoload := LTerm_resources.get_bool "autoload" res <> Some false;
return ())
(function
| Unix.Unix_error(Unix.ENOENT, _, _) ->
return ()
| Unix.Unix_error (error, func, arg) ->
Lwt_log.error_f "cannot load styles from %S: %s: %s" fn func (Unix.error_message error)
| exn -> Lwt.fail exn)
let rec stylise_filter_layout stylise tokens =
match tokens with

View File

@ -1,882 +0,0 @@
(*
* pa_optcomp.ml
* -------------
* Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org>
* Licence : BSD3
*
* This file is a part of optcomp.
*)
open Camlp4.Sig
open Camlp4.PreCast
external filter : 'a Gram.not_filtered -> 'a = "%identity"
external not_filtered : 'a -> 'a Gram.not_filtered = "%identity"
(* Subset of supported caml types *)
type typ =
| Tvar of string
| Tbool
| Tint
| Tchar
| Tstring
| Ttuple of typ list
(* Subset of supported caml values *)
type value =
| Bool of bool
| Int of int
| Char of char
| String of string
| Tuple of value list
type ident = string
(* An identifier. It is either a lower or a upper identifier. *)
module Env = Map.Make(struct type t = ident let compare = compare end)
type env = value Env.t
type directive =
| Dir_let of Ast.patt * Ast.expr
| Dir_default of Ast.patt * Ast.expr
| Dir_if of Ast.expr
| Dir_else
| Dir_elif of Ast.expr
| Dir_endif
| Dir_include of Ast.expr
| Dir_error of Ast.expr
| Dir_warning of Ast.expr
| Dir_directory of Ast.expr
(* This one is not part of optcomp but this is one of the directives
handled by camlp4 we probably want to use. *)
| Dir_default_quotation of Ast.expr
(* Quotations are evaluated by the token filters, but are expansed
after. Evaluated quotations are kept in this table, which quotation
id to to values: *)
let quotations : (int, value) Hashtbl.t = Hashtbl.create 42
let next_quotation_id =
let r = ref 0 in
fun _ -> incr r; !r
(* +-----------------------------------------------------------------+
| Environment |
+-----------------------------------------------------------------+ *)
let env = ref Env.empty
let define id value = env := Env.add id value !env
let _ =
define "ocaml_version" (Scanf.sscanf Sys.ocaml_version "%d.%d.%d" (fun major minor patchlevel -> Tuple [Int major; Int minor; Int patchlevel]))
let dirs = ref []
let add_include_dir dir = dirs := dir :: !dirs
(* +-----------------------------------------------------------------+
| Dependencies |
+-----------------------------------------------------------------+ *)
module String_set = Set.Make(String)
(* All depencies of the file being parsed *)
let dependencies = ref String_set.empty
(* Where to write dependencies *)
let dependency_filename = ref None
(* The file being parsed. This is set when the first (token, location)
pair is fetched. *)
let source_filename = ref None
let write_depencies () =
match !dependency_filename, !source_filename with
| None, _
| _, None ->
()
| Some dependency_filename, Some source_filename ->
let oc = open_out dependency_filename in
if not (String_set.is_empty !dependencies) then begin
output_string oc "# automatically generated by optcomp\n";
output_string oc source_filename;
output_string oc ": ";
output_string oc (String.concat " " (String_set.elements !dependencies));
output_char oc '\n'
end;
close_out oc
(* +-----------------------------------------------------------------+
| Value to expression/pattern conversion |
+-----------------------------------------------------------------+ *)
let rec expr_of_value _loc = function
| Bool true -> <:expr< true >>
| Bool false -> <:expr< false >>
| Int x -> <:expr< $int:string_of_int x$ >>
| Char x -> <:expr< $chr:Char.escaped x$ >>
| String x -> <:expr< $str:String.escaped x$ >>
| Tuple [] -> <:expr< () >>
| Tuple [x] -> expr_of_value _loc x
| Tuple l -> <:expr< $tup:Ast.exCom_of_list (List.map (expr_of_value _loc) l)$ >>
let rec patt_of_value _loc = function
| Bool true -> <:patt< true >>
| Bool false -> <:patt< false >>
| Int x -> <:patt< $int:string_of_int x$ >>
| Char x -> <:patt< $chr:Char.escaped x$ >>
| String x -> <:patt< $str:String.escaped x$ >>
| Tuple [] -> <:patt< () >>
| Tuple [x] -> patt_of_value _loc x
| Tuple l -> <:patt< $tup:Ast.paCom_of_list (List.map (patt_of_value _loc) l)$ >>
(* +-----------------------------------------------------------------+
| Value printing |
+-----------------------------------------------------------------+ *)
let string_of_value string_of_bool v =
let buf = Buffer.create 128 in
let rec aux = function
| Bool b ->
Buffer.add_string buf (string_of_bool b)
| Int n ->
Buffer.add_string buf (string_of_int n)
| Char ch ->
Buffer.add_char buf '\'';
Buffer.add_string buf (Char.escaped ch);
Buffer.add_char buf '\''
| String s ->
Buffer.add_char buf '"';
Buffer.add_string buf (String.escaped s);
Buffer.add_char buf '"'
| Tuple [] ->
Buffer.add_string buf "()"
| Tuple (x :: l) ->
Buffer.add_char buf '(';
aux x;
List.iter
(fun x ->
Buffer.add_string buf ", ";
aux x)
l;
Buffer.add_char buf ')'
in
aux v;
Buffer.contents buf
let string_of_value_o v =
string_of_value
(function
| true -> "true"
| false -> "false")
v
let string_of_value_r v =
string_of_value
(function
| true -> "True"
| false -> "False")
v
let string_of_value_no_pretty v =
let buf = Buffer.create 128 in
let rec aux = function
| Bool b ->
Buffer.add_string buf (string_of_bool b)
| Int n ->
Buffer.add_string buf (string_of_int n)
| Char ch ->
Buffer.add_char buf ch
| String s ->
Buffer.add_string buf s;
| Tuple [] ->
Buffer.add_string buf "()"
| Tuple (x :: l) ->
Buffer.add_char buf '(';
aux x;
List.iter
(fun x ->
Buffer.add_string buf ", ";
aux x)
l;
Buffer.add_char buf ')'
in
aux v;
Buffer.contents buf
(* +-----------------------------------------------------------------+
| Expression evaluation |
+-----------------------------------------------------------------+ *)
let rec type_of_value = function
| Bool _ -> Tbool
| Int _ -> Tint
| Char _ -> Tchar
| String _ -> Tstring
| Tuple l -> Ttuple (List.map type_of_value l)
let rec string_of_type = function
| Tvar v -> "'" ^ v
| Tbool -> "bool"
| Tint -> "int"
| Tchar -> "char"
| Tstring -> "string"
| Ttuple l -> "(" ^ String.concat " * " (List.map string_of_type l) ^ ")"
let invalid_type loc expected real =
Loc.raise loc (Failure
(Printf.sprintf "this expression has type %s but is used with type %s"
(string_of_type real) (string_of_type expected)))
let type_of_patt patt =
let rec aux (a, n) = function
| <:patt< $tup:x$ >> ->
let l, x = List.fold_left
(fun (l, x) patt -> let t, x = aux x patt in (t :: l, x))
([], (a, n)) (Ast.list_of_patt x []) in
(Ttuple(List.rev l), x)
| _ ->
(Tvar(Printf.sprintf "%c%s"
(char_of_int (Char.code 'a' + a))
(if n = 0 then "" else string_of_int n)),
if a = 25 then (0, n + 1) else (a + 1, n))
in
fst (aux (0, 0) patt)
let rec eval env = function
(* Literals *)
| <:expr< true >> -> Bool true
| <:expr< false >> -> Bool false
| <:expr< $int:x$ >> -> Int(int_of_string x)
| <:expr< $chr:x$ >> -> Char(Camlp4.Struct.Token.Eval.char x)
| <:expr< $str:x$ >> -> String(Camlp4.Struct.Token.Eval.string ~strict:() x)
(* Tuples *)
| <:expr< $tup:x$ >> -> Tuple(List.map (eval env) (Ast.list_of_expr x []))
(* Variables *)
| <:expr@loc< $lid:x$ >>
| <:expr@loc< $uid:x$ >> ->
begin try
Env.find x env
with
Not_found ->
Loc.raise loc (Failure (Printf.sprintf "unbound value %s" x))
end
(* Value comparing *)
| <:expr< $x$ = $y$ >> -> let x, y = eval_same env x y in Bool(x = y)
| <:expr< $x$ < $y$ >> -> let x, y = eval_same env x y in Bool(x < y)
| <:expr< $x$ > $y$ >> -> let x, y = eval_same env x y in Bool(x > y)
| <:expr< $x$ <= $y$ >> -> let x, y = eval_same env x y in Bool(x <= y)
| <:expr< $x$ >= $y$ >> -> let x, y = eval_same env x y in Bool(x >= y)
| <:expr< $x$ <> $y$ >> -> let x, y = eval_same env x y in Bool(x <> y)
(* min and max *)
| <:expr< min $x$ $y$ >> -> let x, y = eval_same env x y in min x y
| <:expr< max $x$ $y$ >> -> let x, y = eval_same env x y in max x y
(* Arithmetic *)
| <:expr< $x$ + $y$ >> -> Int(eval_int env x + eval_int env y)
| <:expr< $x$ - $y$ >> -> Int(eval_int env x - eval_int env y)
| <:expr< $x$ * $y$ >> -> Int(eval_int env x * eval_int env y)
| <:expr< $x$ / $y$ >> -> Int(eval_int env x / eval_int env y)
| <:expr< $x$ mod $y$ >> -> Int(eval_int env x mod eval_int env y)
(* Boolean operations *)
| <:expr< not $x$ >> -> Bool(not (eval_bool env x))
| <:expr< $x$ or $y$ >> -> Bool(eval_bool env x || eval_bool env y)
| <:expr< $x$ || $y$ >> -> Bool(eval_bool env x || eval_bool env y)
| <:expr< $x$ && $y$ >> -> Bool(eval_bool env x && eval_bool env y)
(* String operations *)
| <:expr< $x$ ^ $y$ >> -> String(eval_string env x ^ eval_string env y)
(* Pair operations *)
| <:expr< fst $x$ >> -> fst (eval_pair env x)
| <:expr< snd $x$ >> -> snd (eval_pair env x)
(* Conversions *)
| <:expr@loc< to_string $x$ >> ->
String(string_of_value_no_pretty (eval env x))
| <:expr@loc< to_int $x$ >> ->
Int
(match eval env x with
| String x -> begin
try
int_of_string x
with exn ->
Loc.raise loc exn
end
| Int x ->
x
| Char x ->
int_of_char x
| Bool _ ->
Loc.raise loc (Failure "cannot convert a boolean to an integer")
| Tuple _ ->
Loc.raise loc (Failure "cannot convert a tuple to an integer"))
| <:expr@loc< to_bool $x$ >> ->
Bool
(match eval env x with
| String x -> begin
try
bool_of_string x
with exn ->
Loc.raise loc exn
end
| Int x ->
Loc.raise loc (Failure "cannot convert an integer to a boolean")
| Char x ->
Loc.raise loc (Failure "cannot convert a character to a boolean")
| Bool x ->
x
| Tuple _ ->
Loc.raise loc (Failure "cannot convert a tuple to a boolean"))
| <:expr@loc< to_char $x$ >> ->
Char
(match eval env x with
| String x ->
if String.length x = 1 then
x.[0]
else
Loc.raise loc (Failure (Printf.sprintf "cannot convert a string of length %d to a character" (String.length x)))
| Int x -> begin
try
char_of_int x
with exn ->
Loc.raise loc exn
end
| Char x ->
x
| Bool _ ->
Loc.raise loc (Failure "cannot convert a boolean to a character")
| Tuple _ ->
Loc.raise loc (Failure "cannot convert a tuple to a character"))
(* Pretty printing *)
| <:expr@loc< show $x$ >> ->
String(string_of_value_o (eval env x))
(* Let-binding *)
| <:expr< let $p$ = $x$ in $y$ >> ->
let vx = eval env x in
let env =
try
bind true env p vx
with Exit ->
invalid_type (Ast.loc_of_expr x) (type_of_patt p) (type_of_value vx)
in
eval env y
| e -> Loc.raise (Ast.loc_of_expr e) (Stream.Error "expression not supported")
and bind override env patt value = match patt with
| <:patt< $lid:id$ >>
| <:patt< $uid:id$ >> ->
if override || not (Env.mem id env) then
Env.add id value env
else
env
| <:patt< $tup:patts$ >> ->
let patts = Ast.list_of_patt patts [] in
begin match value with
| Tuple values when List.length values = List.length patts ->
List.fold_left2 (bind override) env patts values
| _ ->
raise Exit
end
| <:patt< _ >> ->
env
| _ ->
Loc.raise (Ast.loc_of_patt patt) (Stream.Error "pattern not supported")
and eval_same env ex ey =
let vx = eval env ex and vy = eval env ey in
let tx = type_of_value vx and ty = type_of_value vy in
if tx = ty then
(vx, vy)
else
invalid_type (Ast.loc_of_expr ey) tx ty
and eval_int env e = match eval env e with
| Int x -> x
| v -> invalid_type (Ast.loc_of_expr e) Tint (type_of_value v)
and eval_bool env e = match eval env e with
| Bool x -> x
| v -> invalid_type (Ast.loc_of_expr e) Tbool (type_of_value v)
and eval_string env e = match eval env e with
| String x -> x
| v -> invalid_type (Ast.loc_of_expr e) Tstring (type_of_value v)
and eval_char env e = match eval env e with
| Char x -> x
| v -> invalid_type (Ast.loc_of_expr e) Tchar (type_of_value v)
and eval_pair env e = match eval env e with
| Tuple [x; y] -> (x, y)
| v -> invalid_type (Ast.loc_of_expr e) (Ttuple [Tvar "a"; Tvar "b"]) (type_of_value v)
(* +-----------------------------------------------------------------+
| Parsing of directives |
+-----------------------------------------------------------------+ *)
let rec skip_space stream = match Stream.peek stream with
| Some((BLANKS _ | COMMENT _), _) ->
Stream.junk stream;
skip_space stream
| _ ->
()
let rec parse_eol stream =
let tok, loc = Stream.next stream in
match tok with
| BLANKS _ | COMMENT _ ->
parse_eol stream
| NEWLINE | EOI ->
()
| _ ->
Loc.raise loc (Stream.Error "end of line expected")
(* Return wether a keyword can be interpreted as an identifier *)
let keyword_is_id str =
let rec aux i =
if i = String.length str then
true
else
match str.[i] with
| 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' ->
aux (i + 1)
| _ ->
false
in
aux 0
let parse_ident stream =
skip_space stream;
let tok, loc = Stream.next stream in
begin match tok with
| LIDENT id | UIDENT id ->
(id, loc)
| KEYWORD kwd when keyword_is_id kwd ->
(kwd, loc)
| _ ->
Loc.raise loc (Stream.Error "identifier expected")
end
let parse_until entry is_stop_token stream =
(* Lists of opened brackets *)
let opened_brackets = ref [] in
let eoi = ref None in
let end_loc = ref Loc.ghost in
(* Return the next token of [stream] until all opened parentheses
have been closed and a newline is reached *)
let rec next_token _ =
match !eoi with
| Some _ as x -> x
| None ->
Some(match Stream.next stream, !opened_brackets with
| (tok, loc), [] when is_stop_token tok ->
end_loc := loc;
let x = (EOI, loc) in
eoi := Some x;
x
| (EOI, loc), _ ->
end_loc := loc;
let x = (EOI, loc) in
eoi := Some x;
x
| ((KEYWORD ("(" | "[" | "{" as b) | SYMBOL ("(" | "[" | "{" as b)), _) as x, l ->
opened_brackets := b :: l;
x
| ((KEYWORD ")" | SYMBOL ")"), loc) as x, "(" :: l ->
opened_brackets := l;
x
| ((KEYWORD "]" | SYMBOL "]"), loc) as x, "[" :: l ->
opened_brackets := l;
x
| ((KEYWORD "}" | SYMBOL "}"), loc) as x, "{" :: l ->
opened_brackets := l;
x
| x, _ ->
x)
in
let expr =
Gram.parse_tokens_before_filter entry
(not_filtered (Stream.from next_token))
in
(expr, Loc.join !end_loc)
let parse_expr stream =
parse_until Syntax.expr_eoi (fun tok -> tok = NEWLINE) stream
let parse_patt stream =
parse_until Syntax.patt_eoi (function
| SYMBOL "=" | KEYWORD "=" -> true
| _ -> false) stream
let parse_directive stream = match Stream.peek stream with
| Some((KEYWORD "#" | SYMBOL "#"), loc) -> begin
Stream.junk stream;
let dir, loc_dir = parse_ident stream in
match dir with
| "let" ->
let patt, _ = parse_patt stream in
let expr, end_loc = parse_expr stream in
Some(Dir_let(patt, expr), Loc.merge loc end_loc)
| "let_default" ->
let patt, _ = parse_patt stream in
let expr, end_loc = parse_expr stream in
Some(Dir_default(patt, expr), Loc.merge loc end_loc)
| "if" ->
let expr, end_loc = parse_expr stream in
Some(Dir_if expr, Loc.merge loc end_loc)
| "else" ->
parse_eol stream;
Some(Dir_else, Loc.merge loc loc_dir)
| "elif" ->
let expr, end_loc = parse_expr stream in
Some(Dir_elif expr, Loc.merge loc end_loc)
| "endif" ->
parse_eol stream;
Some(Dir_endif, Loc.merge loc loc_dir)
| "include" ->
let expr, end_loc = parse_expr stream in
Some(Dir_include expr, Loc.merge loc end_loc)
| "directory" ->
let expr, end_loc = parse_expr stream in
Some(Dir_directory expr, Loc.merge loc end_loc)
| "error" ->
let expr, end_loc = parse_expr stream in
Some(Dir_error expr, Loc.merge loc end_loc)
| "warning" ->
let expr, end_loc = parse_expr stream in
Some(Dir_warning expr, Loc.merge loc end_loc)
| "default_quotation" ->
let expr, end_loc = parse_expr stream in
Some(Dir_default_quotation expr, Loc.merge loc end_loc)
| _ ->
Loc.raise loc_dir (Stream.Error (Printf.sprintf "unknown directive ``%s''" dir))
end
| _ ->
None
let parse_command_line_define str =
match Gram.parse_string Syntax.expr (Loc.mk "<command line>") str with
| <:expr< $lid:id$ = $e$ >>
| <:expr< $uid:id$ = $e$ >> -> define id (eval !env e)
| _ -> invalid_arg str
(* +-----------------------------------------------------------------+
| Block skipping |
+-----------------------------------------------------------------+ *)
let rec skip_line stream =
match Stream.next stream with
| NEWLINE, _ -> ()
| EOI, loc -> Loc.raise loc (Stream.Error "#endif missing")
| _ -> skip_line stream
let rec next_directive stream = match parse_directive stream with
| Some dir -> dir
| None -> skip_line stream; next_directive stream
let rec next_endif stream =
let dir, loc = next_directive stream in
match dir with
| Dir_if _ -> skip_if stream; next_endif stream
| Dir_else
| Dir_elif _
| Dir_endif -> dir
| _ -> next_endif stream
and skip_if stream =
let dir, loc = next_directive stream in
match dir with
| Dir_if _ ->
skip_if stream;
skip_if stream
| Dir_else ->
skip_else stream
| Dir_elif _ ->
skip_if stream
| Dir_endif ->
()
| _ -> skip_if stream
and skip_else stream =
let dir, loc = next_directive stream in
match dir with
| Dir_if _ ->
skip_if stream;
skip_else stream
| Dir_else ->
Loc.raise loc (Stream.Error "#else without #if")
| Dir_elif _ ->
Loc.raise loc (Stream.Error "#elif without #if")
| Dir_endif ->
()
| _ ->
skip_else stream
(* +-----------------------------------------------------------------+
| Token filtering |
+-----------------------------------------------------------------+ *)
type context = Ctx_if | Ctx_else
(* State of the token filter *)
type state = {
stream : (Gram.Token.t * Loc.t) Stream.t;
(* Input stream *)
mutable bol : bool;
(* Wether we are at the beginning of a line *)
mutable stack : context list;
(* Nested contexts *)
on_eoi : Gram.Token.t * Loc.t -> Gram.Token.t * Loc.t;
(* Eoi handler, it is used to restore the previous sate on #include
directives *)
}
(* Read and return one token *)
let really_read state =
let tok, loc = Stream.next state.stream in
state.bol <- tok = NEWLINE;
match tok with
| QUOTATION ({ q_name = "optcomp" } as quot) ->
let id = next_quotation_id () in
Hashtbl.add quotations id (eval !env (Gram.parse_string
Syntax.expr_eoi
(Loc.move `start quot.q_shift loc)
quot.q_contents));
(* Replace the quotation by its id *)
(QUOTATION { quot with q_contents = string_of_int id }, loc)
| EOI ->
(* If end of input is reached, we call the eoi handler. It may
continue if we were parsing an included file *)
if state.stack <> [] then
Loc.raise loc (Stream.Error "#endif missing");
state.on_eoi (tok, loc)
| _ ->
(tok, loc)
(* Return the next token from a stream, interpreting directives. *)
let rec next_token lexer state_ref =
let state = !state_ref in
if state.bol then
match parse_directive state.stream, state.stack with
| Some(Dir_if e, _), _ ->
let rec aux e =
if eval_bool !env e then begin
state.stack <- Ctx_if :: state.stack;
next_token lexer state_ref
end else
match next_endif state.stream with
| Dir_else ->
state.stack <- Ctx_else :: state.stack;
next_token lexer state_ref
| Dir_elif e ->
aux e
| Dir_endif ->
next_token lexer state_ref
| _ ->
assert false
in
aux e
| Some(Dir_else, loc), ([] | Ctx_else :: _) ->
Loc.raise loc (Stream.Error "#else without #if")
| Some(Dir_elif _, loc), ([] | Ctx_else :: _) ->
Loc.raise loc (Stream.Error "#elif without #if")
| Some(Dir_endif, loc), [] ->
Loc.raise loc (Stream.Error "#endif without #if")
| Some(Dir_else, loc), Ctx_if :: l ->
skip_else state.stream;
state.stack <- l;
next_token lexer state_ref
| Some(Dir_elif _, loc), Ctx_if :: l ->
skip_if state.stream;
state.stack <- l;
next_token lexer state_ref
| Some(Dir_endif, loc), _ :: l ->
state.stack <- l;
next_token lexer state_ref
| Some(Dir_let(patt, expr), _), _ ->
let value = eval !env expr in
env := (
try
bind true !env patt value;
with Exit ->
invalid_type (Ast.loc_of_expr expr) (type_of_patt patt) (type_of_value value)
);
next_token lexer state_ref
| Some(Dir_default(patt, expr), _), _ ->
let value = eval !env expr in
env := (
try
bind false !env patt value;
with Exit ->
invalid_type (Ast.loc_of_expr expr) (type_of_patt patt) (type_of_value value)
);
next_token lexer state_ref
| Some(Dir_include e, _), _ ->
let fname = eval_string !env e in
(* Try to looks up in all include directories *)
let fname =
try
List.find (fun dir -> Sys.file_exists (Filename.concat dir fname)) !dirs
with
(* Just try in the current directory *)
Not_found -> fname
in
dependencies := String_set.add fname !dependencies;
let ic = open_in fname in
let nested_state = {
stream = lexer fname ic;
bol = true;
stack = [];
on_eoi = (fun _ ->
(* Restore previous state and close channel on
eoi *)
state_ref := state;
close_in ic;
next_token lexer state_ref)
} in
(* Replace current state with the new one *)
state_ref := nested_state;
next_token lexer state_ref
| Some(Dir_directory e, loc), _ ->
let dir = eval_string !env e in
add_include_dir dir;
next_token lexer state_ref
| Some(Dir_error e, loc), _ ->
Loc.raise loc (Failure (eval_string !env e))
| Some(Dir_warning e, loc), _ ->
Syntax.print_warning loc (eval_string !env e);
next_token lexer state_ref
| Some(Dir_default_quotation e, loc), _ ->
Syntax.Quotation.default := eval_string !env e;
next_token lexer state_ref
| None, _ ->
really_read state
else
really_read state
let default_lexer fname ic =
Token.Filter.filter (Gram.get_filter ()) (filter (Gram.lex (Loc.mk fname) (Stream.of_channel ic)))
let stream_filter lexer filter stream =
(* Set the source filename *)
begin
match !source_filename with
| Some _ ->
()
| None ->
match Stream.peek stream with
| None ->
()
| Some(tok, loc) ->
source_filename := Some(Loc.file_name loc)
end;
let state_ref = ref { stream = stream;
bol = true;
stack = [];
on_eoi = (fun x -> x) } in
filter (Stream.from (fun _ -> Some(next_token lexer state_ref)))
let filter ?(lexer=default_lexer) stream = stream_filter lexer (fun x -> x) stream
(* +-----------------------------------------------------------------+
| Quotations expansion |
+-----------------------------------------------------------------+ *)
let get_quotation_value str =
Hashtbl.find quotations (int_of_string str)
let expand f loc _ contents =
try
f loc (get_quotation_value contents)
with exn ->
Loc.raise loc (Failure "fatal error in optcomp!")
(* +-----------------------------------------------------------------+
| Registration |
+-----------------------------------------------------------------+ *)
let _ =
Camlp4.Options.add "-let" (Arg.String parse_command_line_define)
"<string> Binding for a #let directive.";
Camlp4.Options.add "-I" (Arg.String add_include_dir)
"<string> Add a directory to #include search path.";
Camlp4.Options.add "-depend"
(Arg.String (fun filename -> dependency_filename := Some filename))
"<file> Write dependencies to <file>.";
Pervasives.at_exit write_depencies;
Syntax.Quotation.add "optcomp" Syntax.Quotation.DynAst.expr_tag (expand expr_of_value);
Syntax.Quotation.add "optcomp" Syntax.Quotation.DynAst.patt_tag (expand patt_of_value);
Gram.Token.Filter.define_filter (Gram.get_filter ()) (stream_filter default_lexer)