2012-02-11 09:21:07 +00:00
(*
* uTop_main . ml
* - - - - - - - - - - - -
* Copyright : ( c ) 2011 , Jeremie Dimino < jeremie @ dimino . org >
* Licence : BSD3
*
* This file is a part of utop .
* )
open CamomileLibraryDyn . Camomile
open Lwt_react
open LTerm_text
open LTerm_geom
open UTop_token
open UTop_styles
open UTop_private
2014-10-18 16:35:39 +00:00
let return , ( > > = ) = Lwt . return , Lwt . ( > > = )
2012-02-11 09:21:07 +00:00
module String_set = Set . Make ( String )
2012-02-15 15:49:29 +00:00
exception Term of int
2012-02-11 09:21:07 +00:00
(* +-----------------------------------------------------------------+
| History |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
2012-02-13 14:57:25 +00:00
let save_history () =
match ! UTop . history_file_name with
| None ->
return ()
| Some fn ->
2014-10-18 16:35:39 +00:00
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 )
2012-02-13 14:57:25 +00:00
2012-02-11 09:21:07 +00:00
let init_history () =
(* Save history on exit. *)
2012-02-13 14:57:25 +00:00
Lwt_main . at_exit save_history ;
2012-02-11 09:21:07 +00:00
(* Load history. *)
2012-02-12 19:37:12 +00:00
match ! UTop . history_file_name with
| None ->
return ()
| Some fn ->
2014-10-18 16:35:39 +00:00
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 )
2012-02-11 09:21:07 +00:00
(* +-----------------------------------------------------------------+
| offset - -> index |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
(* Return the index ( in unicode characters ) of the character starting
a offset ( in bytes ) [ ofs ] in [ str ] . * )
let index_of_offset src ofs =
let rec aux idx ofs' =
if ofs' = ofs then
idx
else if ofs' > ofs then
idx - 1
else if ofs' = String . length src then
- 1
else
aux ( idx + 1 ) ( Zed_utf8 . unsafe_next src ofs' )
in
aux 0 0
let convert_locs str locs = List . map ( fun ( a , b ) -> ( index_of_offset str a , index_of_offset str b ) ) locs
(* +-----------------------------------------------------------------+
| The read - line class |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
2017-04-19 21:34:49 +00:00
# if OCAML_VERSION > = ( 4 , 04 , 0 )
let ast_impl_kind = Pparse . Structure
2017-04-20 12:34:48 +00:00
# else
2017-04-19 21:34:49 +00:00
let ast_impl_kind = Config . ast_impl_magic_number
# endif
let preprocess input =
match input with
| Parsetree . Ptop_def pstr ->
Parsetree . Ptop_def
( Pparse . apply_rewriters ~ tool_name : " ocaml " ast_impl_kind pstr )
| _ -> input
2013-04-03 19:18:36 +00:00
let parse_input_multi input =
2012-02-23 14:07:00 +00:00
let buf = Buffer . create 32 in
let result =
UTop . collect_formatters buf [ Format . err_formatter ]
( fun () ->
2013-04-03 19:18:36 +00:00
match ! UTop . parse_use_file input false with
| UTop . Error ( locs , msg ) ->
UTop . Error ( convert_locs input locs , " Error: " ^ msg ^ " \n " )
| UTop . Value phrases ->
2017-04-19 21:34:49 +00:00
try
UTop . Value ( List . map preprocess phrases )
with Pparse . Error error ->
Pparse . report_error Format . str_formatter error ;
UTop . Error ( [] , " Error: " ^ Format . flush_str_formatter () ^ " \n " ) )
2013-04-03 19:18:36 +00:00
in
( result , Buffer . contents buf )
let parse_and_check input eos_is_error =
let buf = Buffer . create 32 in
let result =
UTop . collect_formatters buf [ Format . err_formatter ]
( fun () ->
2017-04-19 21:34:49 +00:00
match ! UTop . parse_toplevel_phrase input eos_is_error with
2012-02-23 14:07:00 +00:00
| UTop . Error ( locs , msg ) ->
2017-04-19 21:34:49 +00:00
UTop . Error ( convert_locs input locs , " Error: " ^ msg ^ " \n " )
2012-02-23 14:07:00 +00:00
| UTop . Value phrase ->
2017-04-19 21:34:49 +00:00
try
let phrase = preprocess phrase in
match UTop . check_phrase phrase with
| None ->
UTop . Value phrase
| Some ( locs , msg ) ->
UTop . Error ( convert_locs input locs , msg )
with Pparse . Error error ->
Pparse . report_error Format . str_formatter error ;
UTop . Error ( [] , " Error: " ^ Format . flush_str_formatter () ^ " \n " ) )
2012-02-23 14:07:00 +00:00
in
( result , Buffer . contents buf )
2012-02-11 09:21:07 +00:00
2015-05-12 15:46:24 +00:00
let add_terminator s =
let terminator = UTop . get_phrase_terminator () in
if Zed_utf8 . ends_with s terminator then
s
else
s ^ terminator
let is_accept : LTerm_read_line . action -> bool = function
| Accept -> true
| action -> action = = UTop . end_and_accept_current_phrase
2016-07-01 13:26:50 +00:00
(* Read a phrase. If the result is a value, it is guaranteed to be a
2012-02-23 14:07:00 +00:00
valid phrase ( i . e . typable and compilable ) . It also returns
warnings printed parsing . * )
2012-02-11 09:21:07 +00:00
class read_phrase ~ term = object ( self )
2012-02-23 14:07:00 +00:00
inherit [ Parsetree . toplevel_phrase UTop . result * string ] LTerm_read_line . engine ~ history : ( LTerm_history . contents UTop . history ) () as super
inherit [ Parsetree . toplevel_phrase UTop . result * string ] LTerm_read_line . term term as super_term
2012-02-11 09:21:07 +00:00
2015-10-29 09:55:31 +00:00
method create_temporary_file_for_external_editor =
Filename . temp_file " utop " " .ml "
2015-10-29 10:07:28 +00:00
method external_editor = UTop . get_external_editor ()
2012-02-11 09:21:07 +00:00
val mutable return_value = None
method eval =
match return_value with
2015-05-12 15:46:24 +00:00
| Some x ->
x
| None -> assert false
2012-02-11 09:21:07 +00:00
2015-08-07 10:03:25 +00:00
method ! send_action action =
let action : LTerm_read_line . action =
if is_accept action && S . value self # mode < > LTerm_read_line . Edition then
Accept
else
action
in
super # send_action action
method ! exec = function
2015-05-12 15:46:24 +00:00
| action :: actions when S . value self # mode = LTerm_read_line . Edition &&
is_accept action -> begin
Zed_macro . add self # macro action ;
2012-02-11 09:21:07 +00:00
let input = Zed_rope . to_string ( Zed_edit . text self # edit ) in
2015-05-12 15:46:24 +00:00
let input =
if action = = UTop . end_and_accept_current_phrase then
add_terminator input
else
input
in
2012-02-11 09:21:07 +00:00
(* Toploop does that: *)
Location . reset () ;
2015-05-12 15:46:24 +00:00
let eos_is_error = not ! UTop . smart_accept in
2012-02-11 09:21:07 +00:00
try
2015-05-12 15:46:24 +00:00
let result = parse_and_check input eos_is_error in
2012-02-11 09:21:07 +00:00
return_value <- Some result ;
2012-02-12 19:04:32 +00:00
LTerm_history . add UTop . history input ;
2017-04-10 21:49:05 +00:00
let out , warnings = result in
begin
match out with
| UTop . Value _ ->
UTop_history . add_input UTop . stashable_session_history input ;
UTop_history . add_warnings UTop . stashable_session_history warnings ;
| ( UTop . Error ( _ , msg ) ) ->
UTop_history . add_bad_input UTop . stashable_session_history input ;
UTop_history . add_warnings UTop . stashable_session_history warnings ;
UTop_history . add_error UTop . stashable_session_history msg ;
end ;
2012-02-11 09:21:07 +00:00
return result
with UTop . Need_more ->
(* Input not finished, continue. *)
self # insert ( UChar . of_char '\n' ) ;
self # exec actions
end
| actions ->
2015-05-12 15:46:24 +00:00
super_term # exec actions
2012-02-11 09:21:07 +00:00
2015-08-07 10:03:25 +00:00
method ! stylise last =
2012-02-11 09:21:07 +00:00
let styled , position = super # stylise last in
(* Syntax highlighting *)
2012-02-22 15:59:31 +00:00
let stylise loc token_style =
for i = loc . idx1 to loc . idx2 - 1 do
2012-02-11 09:21:07 +00:00
let ch , style = styled . ( i ) in
styled . ( i ) <- ( ch , LTerm_style . merge token_style style )
done
in
2012-02-22 15:59:31 +00:00
UTop_styles . stylise stylise ( UTop_lexer . lex_string ( UTop . get_syntax () ) ( LTerm_text . to_string styled ) ) ;
2012-02-11 09:21:07 +00:00
if not last then
(* Parenthesis matching. *)
LTerm_text . stylise_parenthesis styled position styles . style_paren
else begin
match return_value with
2015-05-12 15:46:24 +00:00
| Some ( UTop . Error ( locs , _ ) , _ ) ->
(* Highlight error locations. *)
List . iter
( fun ( start , stop ) ->
2015-08-04 10:26:28 +00:00
for i = max 0 start to min ( Array . length styled ) stop - 1 do
2015-05-12 15:46:24 +00:00
let ch , style = styled . ( i ) in
styled . ( i ) <- ( ch , { style with LTerm_style . underline = Some true } )
done )
locs
| _ ->
()
2012-02-11 09:21:07 +00:00
end ;
( styled , position )
2015-08-07 10:03:25 +00:00
method ! completion =
2012-02-22 15:59:31 +00:00
let pos , words =
UTop_complete . complete
~ syntax : ( UTop . get_syntax () )
~ phrase_terminator : ( UTop . get_phrase_terminator () )
~ input : ( Zed_rope . to_string self # input_prev )
in
2012-02-11 09:21:07 +00:00
self # set_completion pos words
2015-08-07 10:03:25 +00:00
method ! show_box = S . value self # mode < > LTerm_read_line . Edition | | UTop . get_show_box ()
2013-04-26 08:53:59 +00:00
2012-02-11 09:21:07 +00:00
initializer
(* Set the source signal for the size of the terminal. *)
UTop_private . set_size self # size ;
(* Set the source signal for the key sequence. *)
UTop_private . set_key_sequence self # key_sequence ;
(* Set the prompt. *)
self # set_prompt ! UTop . prompt
end
(* +-----------------------------------------------------------------+
| Out phrase printing |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
2012-02-15 17:36:08 +00:00
let fix_string str =
let len = String . length str in
2012-02-15 20:47:40 +00:00
let ofs , _ , _ = Zed_utf8 . next_error str 0 in
if ofs = len then
2012-02-15 17:36:08 +00:00
str
2012-02-15 20:47:40 +00:00
else begin
2012-02-15 17:36:08 +00:00
let buf = Buffer . create ( len + 128 ) in
2012-02-15 20:47:40 +00:00
if ofs > 0 then Buffer . add_substring buf str 0 ofs ;
let rec loop ofs =
2016-02-01 08:55:17 +00:00
Zed_utf8 . add buf ( UChar . of_char str . [ ofs ] ) ;
2012-02-15 20:47:40 +00:00
let ofs1 = ofs + 1 in
let ofs2 , _ , _ = Zed_utf8 . next_error str ofs1 in
if ofs1 < ofs2 then
Buffer . add_substring buf str ofs1 ( ofs2 - ofs1 ) ;
if ofs2 < len then
loop ofs2
else
Buffer . contents buf
in
loop ofs
end
2012-02-15 17:36:08 +00:00
2013-02-06 22:22:03 +00:00
let render_out_phrase term string =
2014-06-24 13:25:49 +00:00
if String . length string > = 100 * 1024 then
LTerm . fprint term string
else begin
let string = fix_string string in
let styled = LTerm_text . of_string string in
let stylise loc token_style =
for i = loc . idx1 to loc . idx2 - 1 do
let ch , style = styled . ( i ) in
styled . ( i ) <- ( ch , LTerm_style . merge token_style style )
done
in
UTop_styles . stylise stylise ( UTop_lexer . lex_string ( UTop . get_syntax () ) string ) ;
LTerm . fprints term styled
end
2012-02-11 09:21:07 +00:00
2013-02-06 22:22:03 +00:00
let orig_print_out_signature = ! Toploop . print_out_signature
let orig_print_out_phrase = ! Toploop . print_out_phrase
2017-04-18 19:42:13 +00:00
let is_implicit_name name =
name < > " " &&
name . [ 0 ] = '_' &&
try
let _ = int_of_string @@ String . sub name 1 ( String . length name - 1 ) in
true
with
Failure _ -> false
2013-02-06 22:22:03 +00:00
let rec map_items unwrap wrap items =
match items with
| [] ->
[]
| item :: items ->
let sig_item , _ = unwrap item in
let name , rec_status =
match sig_item with
| Outcometree . Osig_class ( _ , name , _ , _ , rs )
| Outcometree . Osig_class_type ( _ , name , _ , _ , rs )
| Outcometree . Osig_module ( name , _ , rs )
2014-05-06 16:18:39 +00:00
| Outcometree . Osig_type ( { Outcometree . otype_name = name } , rs ) ->
2013-02-06 22:22:03 +00:00
( name , rs )
2014-05-06 16:18:39 +00:00
| Outcometree . Osig_typext ( { Outcometree . oext_name = name } , _ )
2013-02-06 22:22:03 +00:00
| Outcometree . Osig_modtype ( name , _ )
2016-03-02 17:38:10 +00:00
# if OCAML_VERSION < ( 4 , 03 , 0 )
2013-02-06 22:22:03 +00:00
| Outcometree . Osig_value ( name , _ , _ ) ->
( name , Outcometree . Orec_not )
2016-03-02 17:38:10 +00:00
# else
| Outcometree . Osig_value { oval_name = name ; _ } ->
( name , Outcometree . Orec_not )
2015-03-18 16:47:29 +00:00
| Outcometree . Osig_ellipsis -> ( " " , Outcometree . Orec_not )
# endif
2013-02-06 22:22:03 +00:00
in
2017-04-18 19:42:13 +00:00
let keep =
name = " " | | name . [ 0 ] < > '_' | |
( UTop . get_create_implicits () && is_implicit_name name )
in
2013-02-06 22:22:03 +00:00
if keep then
item :: map_items unwrap wrap items
else
(* Replace the [Orec_next] at the head of items by [Orec_first] *)
let items =
match items with
| [] ->
[]
| item :: items' ->
let sig_item , extra = unwrap item in
match sig_item with
| Outcometree . Osig_class ( a , name , b , c , rs ) ->
if rs = Outcometree . Orec_next then
wrap ( Outcometree . Osig_class ( a , name , b , c , Outcometree . Orec_first ) ) extra :: items'
else
items
| Outcometree . Osig_class_type ( a , name , b , c , rs ) ->
if rs = Outcometree . Orec_next then
wrap ( Outcometree . Osig_class_type ( a , name , b , c , Outcometree . Orec_first ) ) extra :: items'
else
items
| Outcometree . Osig_module ( name , a , rs ) ->
if rs = Outcometree . Orec_next then
wrap ( Outcometree . Osig_module ( name , a , Outcometree . Orec_first ) ) extra :: items'
else
items
2014-05-06 16:18:39 +00:00
| Outcometree . Osig_type ( oty , rs ) ->
2013-02-06 22:22:03 +00:00
if rs = Outcometree . Orec_next then
2014-05-06 16:18:39 +00:00
wrap ( Outcometree . Osig_type ( oty , Outcometree . Orec_first ) ) extra :: items'
2013-02-06 22:22:03 +00:00
else
items
2014-05-06 16:18:39 +00:00
| Outcometree . Osig_typext _
2015-03-18 16:47:29 +00:00
# if OCAML_VERSION > = ( 4 , 03 , 0 )
| Outcometree . Osig_ellipsis
2014-05-06 16:18:39 +00:00
# endif
2013-02-06 22:22:03 +00:00
| Outcometree . Osig_modtype _
| Outcometree . Osig_value _ ->
items
in
map_items unwrap wrap items
let print_out_signature pp items =
if UTop . get_hide_reserved () then
orig_print_out_signature pp ( map_items ( fun x -> ( x , () ) ) ( fun x () -> x ) items )
else
orig_print_out_signature pp items
let print_out_phrase pp phrase =
if UTop . get_hide_reserved () then
let phrase =
match phrase with
| Outcometree . Ophr_eval _
| Outcometree . Ophr_exception _ ->
phrase
| Outcometree . Ophr_signature items ->
Outcometree . Ophr_signature ( map_items ( fun x -> x ) ( fun x y -> ( x , y ) ) items )
in
orig_print_out_phrase pp phrase
else
orig_print_out_phrase pp phrase
let () =
Toploop . print_out_signature := print_out_signature ;
Toploop . print_out_phrase := print_out_phrase
2012-02-11 09:21:07 +00:00
(* +-----------------------------------------------------------------+
2012-10-15 09:45:44 +00:00
| Toplevel expression rewriting |
2012-02-11 09:21:07 +00:00
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
2012-06-15 14:23:21 +00:00
let with_loc loc str = {
Location . txt = str ;
Location . loc = loc ;
}
2012-10-15 09:45:44 +00:00
(* A rule for rewriting a toplevel expression. *)
type rewrite_rule = {
2016-01-07 10:30:06 +00:00
type_to_rewrite : Longident . t ;
mutable path_to_rewrite : Path . t option ;
2012-10-15 09:45:44 +00:00
required_values : Longident . t list ;
(* Values that must exist and be persistent for the rule to apply. *)
rewrite : Location . t -> Parsetree . expression -> Parsetree . expression ;
(* The rewrite function. *)
enabled : bool React . signal ;
(* Whether the rule is enabled or not. *)
}
2012-02-11 09:21:07 +00:00
let longident_lwt_main_run = Longident . Ldot ( Longident . Lident " Lwt_main " , " run " )
2014-02-10 09:42:34 +00:00
let longident_async_thread_safe_block_on_async_exn =
2017-04-26 07:41:43 +00:00
Longident . parse " Async.Thread_safe.block_on_async_exn "
2012-10-15 06:02:59 +00:00
let longident_unit = Longident . Lident " () "
2012-02-11 09:21:07 +00:00
2015-03-18 16:47:29 +00:00
# if OCAML_VERSION > = ( 4 , 03 , 0 )
let nolabel = Asttypes . Nolabel
# else
let nolabel = " "
# endif
2016-01-07 10:30:06 +00:00
let rewrite_rules = [
2012-10-15 09:45:44 +00:00
(* Rewrite Lwt.t expressions to Lwt_main.run <expr> *)
2016-01-07 10:30:06 +00:00
{
type_to_rewrite = Longident . parse " Lwt.t " ;
path_to_rewrite = None ;
2012-10-15 09:45:44 +00:00
required_values = [ longident_lwt_main_run ] ;
2014-02-14 09:49:00 +00:00
rewrite = ( fun loc e ->
let open Ast_helper in
with_default_loc loc ( fun () ->
2015-03-18 16:47:29 +00:00
Exp . apply ( Exp . ident ( with_loc loc longident_lwt_main_run ) ) [ ( nolabel , e ) ]
2014-02-14 09:49:00 +00:00
)
) ;
2012-10-15 09:45:44 +00:00
enabled = UTop . auto_run_lwt ;
} ;
2017-04-26 07:41:43 +00:00
(* Rewrite Async.Defered.t expressions to
Async . Thread_safe . block_on_async_exn ( fun () -> < expr > ) . * )
2016-01-07 10:30:06 +00:00
{
2017-04-26 07:41:43 +00:00
type_to_rewrite = Longident . parse " Async.Deferred.t " ;
2016-01-07 10:30:06 +00:00
path_to_rewrite = None ;
2014-02-10 09:42:34 +00:00
required_values = [ longident_async_thread_safe_block_on_async_exn ] ;
2014-02-14 09:49:00 +00:00
rewrite = ( fun loc e ->
let open Ast_helper in
2014-05-02 09:58:05 +00:00
let punit = Pat . construct ( with_loc loc ( Longident . Lident " () " ) ) None in
2014-02-14 09:49:00 +00:00
with_default_loc loc ( fun () ->
Exp . apply
( Exp . ident ( with_loc loc longident_async_thread_safe_block_on_async_exn ) )
2015-03-18 16:47:29 +00:00
[ ( nolabel , Exp . fun_ nolabel None punit e ) ]
2014-02-14 09:49:00 +00:00
)
) ;
2012-10-15 09:45:44 +00:00
enabled = UTop . auto_run_async ;
2016-01-07 10:30:06 +00:00
}
]
2016-08-15 08:32:20 +00:00
# if OCAML_VERSION > = ( 4 , 04 , 0 )
let lookup_type longident env =
let path = Env . lookup_type longident env in
( path , Env . find_type path env )
# else
let lookup_type = Env . lookup_type
# endif
2016-01-07 10:30:06 +00:00
let rule_path rule =
match rule . path_to_rewrite with
| Some _ as x -> x
| None ->
try
let env = ! Toploop . toplevel_env in
let path =
2016-08-15 08:32:20 +00:00
match lookup_type rule . type_to_rewrite env with
2016-01-07 10:30:06 +00:00
| path , { Types . type_kind = Types . Type_abstract
; Types . type_private = Asttypes . Public
; Types . type_manifest = Some ty
} -> begin
match Ctype . expand_head env ty with
| { Types . desc = Types . Tconstr ( path , _ , _ ) } -> path
| _ -> path
end
| path , _ -> path
in
let opt = Some path in
rule . path_to_rewrite <- opt ;
opt
with _ ->
None
2012-02-11 09:21:07 +00:00
2012-10-15 09:45:44 +00:00
(* Returns whether the given path is persistent. *)
let rec is_persistent_path = function
| Path . Pident id -> Ident . persistent id
| Path . Pdot ( p , _ , _ ) -> is_persistent_path p
| Path . Papply ( _ , p ) -> is_persistent_path p
(* Check that the given long identifier is present in the environment
and is persistent . * )
let is_persistent_in_env longident =
try
is_persistent_path ( fst ( Env . lookup_value longident ! Toploop . toplevel_env ) )
with Not_found ->
false
2012-10-15 06:02:59 +00:00
2016-01-07 10:30:06 +00:00
let rule_matches rule path =
React . S . value rule . enabled &&
( match rule_path rule with
| None -> false
| Some path' -> Path . same path path' ) &&
List . for_all is_persistent_in_env rule . required_values
(* Returns whether the argument is a toplevel expression. *)
let is_eval = function
| { Parsetree . pstr_desc = Parsetree . Pstr_eval _ } -> true
| _ -> false
(* Returns the rewrite rule associated to a type, if any. *)
let rec rule_of_type typ =
match ( Ctype . expand_head ! Toploop . toplevel_env typ ) . Types . desc with
| Types . Tconstr ( path , _ , _ ) -> begin
try
Some ( List . find ( fun rule -> rule_matches rule path ) rewrite_rules )
with _ ->
None
end
| _ ->
None
2014-02-14 09:49:00 +00:00
let rewrite_str_item pstr_item tstr_item =
2014-10-20 12:45:26 +00:00
match pstr_item , tstr_item . Typedtree . str_desc with
2014-02-14 09:49:00 +00:00
| ( { Parsetree . pstr_desc = Parsetree . Pstr_eval ( e , _ ) ;
Parsetree . pstr_loc = loc } ,
Typedtree . Tstr_eval ( { Typedtree . exp_type = typ } , _ ) ) -> begin
match rule_of_type typ with
| Some rule ->
2016-01-07 10:30:06 +00:00
{ Parsetree . pstr_desc = Parsetree . Pstr_eval ( rule . rewrite loc e , [] ) ;
Parsetree . pstr_loc = loc }
2014-02-14 09:49:00 +00:00
| None ->
pstr_item
end
| _ ->
pstr_item
2012-02-11 09:21:07 +00:00
2012-10-15 09:45:44 +00:00
let rewrite phrase =
2012-10-15 06:02:59 +00:00
match phrase with
| Parsetree . Ptop_def pstr ->
2012-10-15 09:45:44 +00:00
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
2014-10-20 12:45:26 +00:00
Parsetree . Ptop_def ( List . map2 rewrite_str_item pstr tstr . Typedtree . str_items )
2012-10-15 09:45:44 +00:00
else
2017-04-12 23:56:26 +00:00
phrase
| Parsetree . Ptop_dir _ ->
phrase
let add_let binding_name def =
let open Parsetree in
match def with
| { pstr_desc = Pstr_eval ( expr , attr ) ; pstr_loc } ->
{
pstr_loc ;
pstr_desc = Pstr_value ( Asttypes . Nonrecursive , [
{
2017-04-18 19:42:13 +00:00
pvb_pat = {
ppat_desc = Ppat_var { txt = binding_name ; loc = pstr_loc ; } ;
ppat_loc = pstr_loc ;
ppat_attributes = [] ;
} ;
pvb_expr = expr ;
pvb_attributes = attr ;
pvb_loc = pstr_loc ;
} ] ) ;
2017-04-12 23:56:26 +00:00
}
| _ ->
def
let bind_expressions name phrase =
match phrase with
| Parsetree . Ptop_def pstr ->
Parsetree . Ptop_def ( List . map ( add_let name ) pstr )
2012-10-15 09:45:44 +00:00
| Parsetree . Ptop_dir _ ->
phrase
2012-10-15 06:02:59 +00:00
2012-02-11 09:21:07 +00:00
(* +-----------------------------------------------------------------+
| Main loop |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
let rec read_phrase term =
2014-10-18 16:35:39 +00:00
Lwt . catch
( fun () -> ( new read_phrase ~ term ) # run )
( function
| Sys . Break ->
LTerm . fprintl term " Interrupted. " > > = fun () ->
read_phrase term
| exn -> Lwt . fail exn )
2012-02-11 09:21:07 +00:00
2012-02-22 16:21:47 +00:00
let print_error term msg =
2014-10-18 16:35:39 +00:00
LTerm . set_style term styles . style_error > > = fun () ->
Lwt_io . print msg > > = fun () ->
LTerm . set_style term LTerm_style . none > > = fun () ->
2012-02-11 09:21:07 +00:00
LTerm . flush term
let rec loop term =
(* Reset completion. *)
UTop_complete . reset () ;
(* increment the command counter. *)
UTop_private . set_count ( S . value UTop_private . count + 1 ) ;
(* Call hooks. *)
Lwt_sequence . iter_l ( fun f -> f () ) UTop . new_command_hooks ;
(* Read interactively user input. *)
let phrase_opt =
Lwt_main . run (
2014-10-18 16:35:39 +00:00
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 )
2016-06-25 19:48:55 +00:00
| UTop . Error ( locs , msg ) ->
2014-10-18 16:35:39 +00:00
print_error term msg > > = fun () ->
return None )
( fun () -> LTerm . flush term )
2012-02-11 09:21:07 +00:00
)
in
match phrase_opt with
| Some phrase ->
2012-10-15 09:45:44 +00:00
(* Rewrite toplevel expressions. *)
2017-04-12 23:56:26 +00:00
let count = S . value UTop_private . count in
2017-04-18 19:42:13 +00:00
let phrase = rewrite phrase in
let phrase =
if UTop . get_create_implicits () then
let binding_name = Printf . sprintf " _%d " count in
bind_expressions binding_name phrase
else
phrase
in
2012-02-11 09:21:07 +00:00
(* Set the margin of standard formatters. *)
2015-08-04 10:44:36 +00:00
UTop_private . set_margin Format . std_formatter ;
UTop_private . set_margin Format . err_formatter ;
2012-02-22 16:21:47 +00:00
(* Formatter to get the output phrase. *)
let buffer = Buffer . create 1024 in
let pp = Format . formatter_of_buffer buffer in
2015-08-04 10:44:36 +00:00
UTop_private . set_margin pp ;
2012-02-17 10:51:27 +00:00
( try
2013-05-21 09:26:59 +00:00
Env . reset_cache_toplevel () ;
2014-05-02 15:43:30 +00:00
if ! Clflags . dump_parsetree then Printast . top_phrase pp phrase ;
if ! Clflags . dump_source then Pprintast . top_phrase pp phrase ;
2012-02-22 16:21:47 +00:00
ignore ( Toploop . execute_phrase true pp phrase ) ;
(* Flush everything. *)
Format . pp_print_flush Format . std_formatter () ;
Format . pp_print_flush Format . err_formatter () ;
flush stdout ;
flush stderr ;
(* Get the string printed. *)
Format . pp_print_flush pp () ;
let string = Buffer . contents buffer in
2017-04-10 21:49:05 +00:00
UTop_history . add_output UTop . stashable_session_history string ;
2012-02-22 16:21:47 +00:00
match phrase with
| Parsetree . Ptop_def _ ->
(* The string is an output phrase, colorize it. *)
2013-07-08 12:15:52 +00:00
Lwt_main . run ( render_out_phrase term string )
2012-02-22 16:21:47 +00:00
| Parsetree . Ptop_dir _ ->
(* The string is an error message. *)
Lwt_main . run ( print_error term string )
2012-02-17 10:51:27 +00:00
with exn ->
(* The only possible errors are directive errors. *)
let msg = UTop . get_message Errors . report_error exn in
(* Skip the dumb location. *)
let msg =
try
let idx = String . index msg '\n' + 1 in
String . sub msg idx ( String . length msg - idx )
with Not_found ->
msg
in
2012-02-22 16:21:47 +00:00
Lwt_main . run ( print_error term msg ) ) ;
2012-02-11 09:21:07 +00:00
loop term
| None ->
loop term
(* +-----------------------------------------------------------------+
| Welcome message |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
let welcome term =
(* Create a context to render the welcome message. *)
let size = LTerm . size term in
let size = { rows = 3 ; cols = size . cols } in
let matrix = LTerm_draw . make_matrix size in
let ctx = LTerm_draw . context matrix size in
(* Draw the message in a box. *)
let message = Printf . sprintf " Welcome to utop version %s (using OCaml version %s)! " UTop . version Sys . ocaml_version in
LTerm_draw . fill_style ctx LTerm_style . ( { none with foreground = Some lcyan } ) ;
LTerm_draw . draw_hline ctx 0 0 size . cols LTerm_draw . Light ;
LTerm_draw . draw_frame ctx {
row1 = 0 ;
row2 = 3 ;
col1 = ( size . cols - ( String . length message + 4 ) ) / 2 ;
col2 = ( size . cols + ( String . length message + 4 ) ) / 2 ;
} LTerm_draw . Light ;
LTerm_draw . draw_styled ctx 1 ( ( size . cols - String . length message ) / 2 ) ( eval [ B_fg LTerm_style . yellow ; S message ] ) ;
(* Render to the screen. *)
2014-10-18 16:35:39 +00:00
LTerm . print_box term matrix > > = fun () ->
2012-02-11 09:21:07 +00:00
(* Move to after the box. *)
2014-10-18 16:35:39 +00:00
LTerm . fprint term " \n " > > = fun () ->
2012-02-11 09:21:07 +00:00
LTerm . flush term
(* +-----------------------------------------------------------------+
| Classic mode |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
let read_input_classic prompt buffer len =
let rec loop i =
if i = len then
return ( i , false )
else
Lwt_io . read_char_opt Lwt_io . stdin > > = function
| Some c ->
2014-05-02 09:58:05 +00:00
Bytes . set buffer i c ;
2012-02-11 09:21:07 +00:00
if c = '\n' then
return ( i + 1 , false )
else
loop ( i + 1 )
| None ->
return ( i , true )
in
2014-10-18 16:35:39 +00:00
Lwt_main . run ( Lwt_io . write Lwt_io . stdout prompt > > = fun () -> loop 0 )
2012-02-11 09:21:07 +00:00
(* +-----------------------------------------------------------------+
| Emacs mode |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
module Emacs ( M : sig end ) = struct
(* Copy standard output, which will be used to send commands. *)
let command_oc = Unix . out_channel_of_descr ( Unix . dup Unix . stdout )
2012-02-12 20:40:29 +00:00
let split_at ? ( trim = false ) ch str =
2012-02-11 09:21:07 +00:00
let rec aux i j =
if j = String . length str then
2012-02-12 20:40:29 +00:00
if trim && i = j then
[]
else
[ String . sub str i ( j - i ) ]
else if str . [ j ] = ch then
2012-02-11 09:21:07 +00:00
String . sub str i ( j - i ) :: aux ( j + 1 ) ( j + 1 )
else
aux i ( j + 1 )
in
aux 0 0
(* +---------------------------------------------------------------+
| Sending commands to Emacs |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
(* Mutex used to send commands to Emacs. *)
let command_mutex = Mutex . create ()
let send command argument =
Mutex . lock command_mutex ;
output_string command_oc command ;
output_char command_oc ':' ;
output_string command_oc argument ;
output_char command_oc '\n' ;
flush command_oc ;
Mutex . unlock command_mutex
(* Keep the [utop-phrase-terminator] variable of the emacs part in sync. *)
let () =
S . keep ( S . map ( send " phrase-terminator " ) UTop . phrase_terminator )
(* +---------------------------------------------------------------+
| Standard outputs redirection |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
(* The output of ocaml ( stdout and stderr ) is redirected so the
emacs parts of utop can recognize it . * )
(* Continuously copy the output of ocaml to Emacs. *)
let rec copy_output which ic =
let line = input_line ic in
send which line ;
copy_output which ic
(* Create a thread which redirect the given output: *)
let redirect which fd =
let fdr , fdw = Unix . pipe () in
Unix . dup2 fdw fd ;
Unix . close fdw ;
Thread . create ( copy_output which ) ( Unix . in_channel_of_descr fdr )
(* Redirects stdout and stderr: *)
let _ = redirect " stdout " Unix . stdout
let _ = redirect " stderr " Unix . stderr
(* +---------------------------------------------------------------+
| Loop |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
let read_line () =
let behavior = Sys . signal Sys . sigint Sys . Signal_ignore in
try
let line = Lwt_main . run ( Lwt_io . read_line_opt Lwt_io . stdin ) in
Sys . set_signal Sys . sigint behavior ;
line
with exn ->
Sys . set_signal Sys . sigint behavior ;
raise exn
let read_command () =
match read_line () with
| None ->
None
| Some line ->
match try Some ( String . index line ':' ) with Not_found -> None with
| None ->
send " stderr " " ':' missing! " ;
exit 1
| Some idx ->
Some ( String . sub line 0 idx , String . sub line ( idx + 1 ) ( String . length line - ( idx + 1 ) ) )
2012-02-12 20:40:29 +00:00
let read_data () =
2012-02-11 09:21:07 +00:00
let buf = Buffer . create 1024 in
let rec loop first =
match read_command () with
| None ->
send " stderr " " 'end' command missing! " ;
exit 1
| Some ( " data " , data ) ->
if not first then Buffer . add_char buf '\n' ;
Buffer . add_string buf data ;
loop false
| Some ( " end " , _ ) ->
Buffer . contents buf
| Some ( command , argument ) ->
Printf . ksprintf ( send " stderr " ) " 'data' or 'end' command expected, got %S! " command ;
exit 1
in
loop true
2013-04-14 11:32:04 +00:00
let process_checked_phrase phrase =
2013-04-03 19:18:36 +00:00
(* Rewrite toplevel expressions. *)
let phrase = rewrite phrase in
try
2013-05-21 09:26:59 +00:00
Env . reset_cache_toplevel () ;
2013-04-03 19:18:36 +00:00
ignore ( Toploop . execute_phrase true Format . std_formatter phrase ) ;
true
with exn ->
(* The only possible errors are directive errors. *)
let msg = UTop . get_message Errors . report_error exn in
(* Skip the dumb location. *)
let msg =
try
let idx = String . index msg '\n' + 1 in
String . sub msg idx ( String . length msg - idx )
with Not_found ->
msg
in
List . iter ( send " stderr " ) ( split_at ~ trim : true '\n' msg ) ;
false
2012-02-12 20:40:29 +00:00
let process_input add_to_history eos_is_error =
let input = read_data () in
2013-04-03 19:18:36 +00:00
let result , warnings = parse_and_check input eos_is_error in
2012-02-23 14:07:00 +00:00
match result with
2013-04-03 19:18:36 +00:00
| UTop . Value phrase ->
2012-02-11 09:21:07 +00:00
send " accept " " " ;
2012-02-23 14:07:00 +00:00
List . iter ( send " stderr " ) ( split_at ~ trim : true '\n' warnings ) ;
2012-02-12 20:40:29 +00:00
if add_to_history then LTerm_history . add UTop . history input ;
2013-04-03 19:18:36 +00:00
ignore ( process_checked_phrase phrase )
2012-02-11 09:21:07 +00:00
| UTop . Error ( locs , msg ) ->
send " accept " ( String . concat " , " ( List . map ( fun ( a , b ) -> Printf . sprintf " %d,%d " a b ) locs ) ) ;
2012-02-23 14:07:00 +00:00
List . iter ( send " stderr " ) ( split_at ~ trim : true '\n' warnings ) ;
2012-02-15 17:04:33 +00:00
if add_to_history then LTerm_history . add UTop . history input ;
2012-02-12 20:40:29 +00:00
List . iter ( send " stderr " ) ( split_at ~ trim : true '\n' msg )
2012-02-11 09:21:07 +00:00
2013-04-03 19:18:36 +00:00
let send_error locs msg warnings =
send " accept " ( String . concat " , " ( List . map ( fun ( a , b ) -> Printf . sprintf " %d,%d " a b ) locs ) ) ;
match warnings with
| Some warnings -> List . iter ( send " stderr " ) ( split_at ~ trim : true '\n' warnings )
| None -> () ;
List . iter ( send " stderr " ) ( split_at ~ trim : true '\n' msg )
let process_input_multi () =
let input = read_data () in
let result , warnings = parse_input_multi input in
2013-04-14 11:32:04 +00:00
let typecheck phrase =
2013-04-26 08:53:59 +00:00
match UTop . check_phrase phrase with
2013-04-03 19:18:36 +00:00
| None -> None
| Some ( locs , msg ) -> Some ( convert_locs input locs , msg ) (* FIXME *)
in
match result with
| UTop . Value phrases ->
send " accept " " " ;
List . iter ( send " stderr " ) ( split_at ~ trim : true '\n' warnings ) ;
let rec loop = function
| ( phrase :: more_phrases ) -> begin
match typecheck phrase with
| Some ( locs , msg ) ->
send_error locs msg None
| None ->
let success = process_checked_phrase phrase in
if success then
2013-04-03 20:02:56 +00:00
loop more_phrases
2013-04-03 19:18:36 +00:00
else
()
end
| [] ->
()
in
loop phrases
| UTop . Error ( locs , msg ) ->
send_error locs msg ( Some warnings )
2012-02-11 09:21:07 +00:00
let rec loop () =
(* Reset completion. *)
UTop_complete . reset () ;
(* Increment the command counter. *)
UTop_private . set_count ( S . value UTop_private . count + 1 ) ;
(* Call hooks. *)
Lwt_sequence . iter_l ( fun f -> f () ) UTop . new_command_hooks ;
(* Tell emacs we are ready. *)
send " prompt " " " ;
2012-02-12 20:40:29 +00:00
loop_commands ( LTerm_history . contents UTop . history ) []
2012-02-11 09:21:07 +00:00
2012-02-12 20:40:29 +00:00
and loop_commands history_prev history_next =
2012-02-11 09:21:07 +00:00
match read_command () with
| None ->
()
2012-02-12 20:40:29 +00:00
| Some ( " input " , arg ) ->
let args = split_at ',' arg in
let allow_incomplete = List . mem " allow-incomplete " args
and add_to_history = List . mem " add-to-history " args in
2012-02-11 09:21:07 +00:00
let continue =
try
2012-02-12 20:40:29 +00:00
process_input add_to_history ( not allow_incomplete ) ;
2012-02-11 09:21:07 +00:00
false
with UTop . Need_more ->
send " continue " " " ;
true
in
if continue then
2012-02-12 20:40:29 +00:00
loop_commands history_prev history_next
2012-02-11 09:21:07 +00:00
else
loop ()
2013-04-03 20:02:56 +00:00
| Some ( " input-multi " , _ ) ->
2013-04-03 19:18:36 +00:00
let continue =
try
process_input_multi () ;
false
with UTop . Need_more ->
send " continue " " " ;
true
in
if continue then
loop_commands history_prev history_next
else
loop ()
2012-02-11 09:21:07 +00:00
| Some ( " complete " , _ ) ->
2012-02-12 20:40:29 +00:00
let input = read_data () in
2012-02-22 15:59:31 +00:00
let start , words =
UTop_complete . complete
~ syntax : ( UTop . get_syntax () )
~ phrase_terminator : ( UTop . get_phrase_terminator () )
~ input
in
2012-02-11 09:21:07 +00:00
let words = List . map fst words in
let prefix = LTerm_read_line . common_prefix words in
let index = String . length input - start in
let suffix =
if index > 0 && index < = String . length prefix then
String . sub prefix index ( String . length prefix - index )
else
" "
in
if suffix = " " then begin
send " completion-start " " " ;
2012-02-12 20:40:29 +00:00
List . iter ( send " completion " ) words ;
2012-02-11 09:21:07 +00:00
send " completion-stop " " " ;
end else
send " completion-word " suffix ;
2012-02-12 20:40:29 +00:00
loop_commands history_prev history_next
| Some ( " history-prev " , _ ) -> begin
let input = read_data () in
match history_prev with
| [] ->
send " history-bound " " " ;
loop_commands history_prev history_next
| entry :: history_prev ->
List . iter ( send " history-data " ) ( split_at '\n' entry ) ;
send " history-end " " " ;
loop_commands history_prev ( input :: history_next )
end
| Some ( " history-next " , _ ) -> begin
let input = read_data () in
match history_next with
| [] ->
send " history-bound " " " ;
loop_commands history_prev history_next
| entry :: history_next ->
List . iter ( send " history-data " ) ( split_at '\n' entry ) ;
send " history-end " " " ;
loop_commands ( input :: history_prev ) history_next
end
2012-02-13 09:21:10 +00:00
| Some ( " exit " , code ) ->
exit ( int_of_string code )
2012-02-13 14:57:25 +00:00
| Some ( " save-history " , code ) ->
Lwt_main . run ( save_history () ) ;
loop_commands history_prev history_next
2012-03-03 17:54:48 +00:00
| Some ( " require " , package ) -> begin
try
Topfind . load_deeply [ package ]
with Fl_package_base . No_such_package ( pkg , reason ) ->
send " no-such-package " pkg
end ;
2012-03-01 03:56:06 +00:00
loop_commands history_prev history_next
2012-02-11 09:21:07 +00:00
| Some ( command , _ ) ->
Printf . ksprintf ( send " stderr " ) " unrecognized command %S! " command ;
exit 1
end
2013-07-08 12:15:52 +00:00
(* +-----------------------------------------------------------------+
| Extra macros |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
2013-10-16 08:18:44 +00:00
let typeof sid =
let id = Longident . parse sid in
2013-07-08 12:15:52 +00:00
let env = ! Toploop . toplevel_env in
2013-10-16 08:18:44 +00:00
let from_type_desc = function
| Types . Tconstr ( path , _ , _ ) ->
let typ_decl = Env . find_type path env in
path , typ_decl
| _ -> assert false
in
let out_sig_item =
try
2016-08-15 08:32:20 +00:00
let ( path , ty_decl ) = lookup_type id env in
2013-10-16 08:18:44 +00:00
let id = Ident . create ( Path . name path ) in
Some ( Printtyp . tree_of_type_declaration id ty_decl Types . Trec_not )
with Not_found ->
try
let ( path , val_descr ) = Env . lookup_value id env in
let id = Ident . create ( Path . name path ) in
Some ( Printtyp . tree_of_value_description id val_descr )
with Not_found ->
try
let lbl_desc = Env . lookup_label id env in
2013-10-25 09:52:32 +00:00
let ( path , ty_decl ) = from_type_desc lbl_desc . Types . lbl_res . Types . desc in
2013-10-16 08:18:44 +00:00
let id = Ident . create ( Path . name path ) in
Some ( Printtyp . tree_of_type_declaration id ty_decl Types . Trec_not )
with Not_found ->
try
2014-05-14 10:37:13 +00:00
let path = Env . lookup_module id env ~ load : true in
2014-02-14 10:01:48 +00:00
let mod_typ = ( Env . find_module path env ) . Types . md_type in
2013-10-16 08:18:44 +00:00
let id = Ident . create ( Path . name path ) in
Some ( Printtyp . tree_of_module id mod_typ Types . Trec_not )
with Not_found ->
try
let ( path , mty_decl ) = Env . lookup_modtype id env in
let id = Ident . create ( Path . name path ) in
Some ( Printtyp . tree_of_modtype_declaration id mty_decl )
with Not_found ->
try
let cstr_desc = Env . lookup_constructor id env in
match cstr_desc . Types . cstr_tag with
| _ ->
2013-10-25 09:52:32 +00:00
let ( path , ty_decl ) = from_type_desc cstr_desc . Types . cstr_res . Types . desc in
2013-10-16 08:18:44 +00:00
let id = Ident . create ( Path . name path ) in
Some ( Printtyp . tree_of_type_declaration id ty_decl Types . Trec_not )
with Not_found ->
None
in
match out_sig_item with
| None ->
Lwt_main . run ( Lazy . force LTerm . stdout > > = fun term ->
print_error term " Unknown type \n " )
| Some osig ->
2013-07-08 12:15:52 +00:00
let buf = Buffer . create 128 in
let pp = Format . formatter_of_buffer buf in
! Toploop . print_out_signature pp [ osig ] ;
Format . pp_print_newline pp () ;
let str = Buffer . contents buf in
Lwt_main . run ( Lazy . force LTerm . stdout > > = fun term -> render_out_phrase term str )
2013-10-16 08:18:44 +00:00
2013-07-08 12:15:52 +00:00
let () =
Hashtbl . add Toploop . directive_table " typeof "
2013-10-16 08:18:44 +00:00
( Toploop . Directive_string typeof )
2013-07-08 12:15:52 +00:00
2012-02-11 09:21:07 +00:00
(* +-----------------------------------------------------------------+
| Entry point |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
let emacs_mode = ref false
2014-04-11 15:06:09 +00:00
let preload = ref []
2012-02-11 09:21:07 +00:00
let prepare () =
Toploop . set_paths () ;
try
2014-04-11 15:06:09 +00:00
let ok =
List . for_all
( function
| ` Packages l -> UTop . require l ; true
| ` Object fn -> Topdirs . load_file Format . err_formatter fn )
( List . rev ! preload )
in
if ok then ! Toploop . toplevel_startup_hook () ;
ok
2012-02-11 09:21:07 +00:00
with exn ->
try
Errors . report_error Format . err_formatter exn ;
false
with exn ->
Format . eprintf " Uncaught exception: %s \n " ( Printexc . to_string exn ) ;
false
2014-04-11 15:06:09 +00:00
let run_script name =
(* To prevent message from camlp4 *)
Sys . interactive := false ;
if not ( prepare () ) then exit 2 ;
let len = Array . length Sys . argv - ! Arg . current in
Array . blit Sys . argv ! Arg . current Sys . argv 0 len ;
Obj . truncate ( Obj . repr Sys . argv ) len ;
Arg . current := 0 ;
Toploop . initialize_toplevel_env () ;
Location . input_name := UTop . input_name ;
if Toploop . use_silently Format . err_formatter name then
2012-02-11 09:21:07 +00:00
exit 0
else
exit 2
let file_argument name =
if Filename . check_suffix name " .cmo " | | Filename . check_suffix name " .cma " then
2014-04-11 15:06:09 +00:00
preload := ` Object name :: ! preload
else
run_script name
2012-02-11 09:21:07 +00:00
let print_version () =
Printf . printf " The universal toplevel for OCaml, version %s, compiled for OCaml version %s \n " UTop . version Sys . ocaml_version ;
exit 0
let print_version_num () =
Printf . printf " %s \n " UTop . version
2013-11-26 13:48:34 +00:00
(* Config from command line *)
let autoload = ref true
2012-02-11 09:21:07 +00:00
let args = Arg . align [
" -absname " , Arg . Set Location . absname , " Show absolute filenames in error message " ;
" -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 " ;
" -no-app-funct " , Arg . Clear Clflags . applicative_functors , " Deactivate applicative functors " ;
" -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 " ;
2014-05-02 15:38:57 +00:00
" -ppx " , Arg . String ( fun ppx -> Clflags . all_ppx := ppx :: ! Clflags . all_ppx ) , " <command> Pipe abstract syntax trees through preprocessor <command> " ;
2012-02-11 09:21:07 +00:00
" -principal " , Arg . Set Clflags . principal , " Check principality of type inference " ;
2014-09-08 19:25:21 +00:00
" -safe-string " , Arg . Clear Clflags . unsafe_string , " Make strings immutable " ;
2013-01-29 20:02:52 +00:00
" -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 " ;
2012-02-11 09:21:07 +00:00
" -rectypes " , Arg . Set Clflags . recursive_types , " Allow arbitrary recursive types " ;
2014-04-11 15:06:09 +00:00
" -stdin " , Arg . Unit ( fun () -> run_script " " ) , " Read script from standard input " ;
2012-02-11 09:21:07 +00:00
" -strict-sequence " , Arg . Set Clflags . strict_sequence , " Left-hand part of a sequence must have type unit " ;
" -unsafe " , Arg . Set Clflags . fast , " Do not compile bounds checking on array and string access " ;
" -version " , Arg . Unit print_version , " Print version and exit " ;
" -vnum " , Arg . Unit print_version_num , " Print version number and exit " ;
" -w " , Arg . String ( Warnings . parse_options false ) ,
Printf . sprintf
" <list> Enable or disable warnings according to <list>: \n \
\ + < spec > enable warnings in < spec > \ n \
\ - < spec > disable warnings in < spec > \ n \
\ @< spec > enable warnings in < spec > and treat them as errors \ n \
\ < spec > can be : \ n \
\ < num > a single warning number \ n \
\ < num1 > .. < num2 > a range of consecutive warning numbers \ n \
\ < letter > a predefined set \ n \
\ default setting is % S " Warnings.defaults_w;
" -warn-error " , Arg . String ( Warnings . parse_options true ) ,
Printf . sprintf
" <list> Enable or disable error status for warnings according to <list> \n \
\ See option - w for the syntax of < list > . \ n \
\ Default setting is % S " Warnings.defaults_warn_error;
" -warn-help " , Arg . Unit Warnings . help_warnings , " Show description of warning numbers " ;
" -emacs " , Arg . Set emacs_mode , " Run in emacs mode " ;
2013-02-06 22:27:09 +00:00
" -hide-reserved " , Arg . Unit ( fun () -> UTop . set_hide_reserved true ) ,
" Hide identifiers starting with a '_' (the default) " ;
" -show-reserved " , Arg . Unit ( fun () -> UTop . set_hide_reserved false ) ,
" Show identifiers starting with a '_' " ;
2017-04-18 19:42:13 +00:00
" -no-implicit-bindings " , Arg . Unit ( fun () -> UTop . set_create_implicits false ) ,
" Don't add implicit bindings for expressions (the default) " ;
" -implicit-bindings " , Arg . Unit ( fun () -> UTop . set_create_implicits true ) ,
" Add implicit bindings: <expr>;; -> let _0 = <expr>;; " ;
2013-11-26 13:48:34 +00:00
" -no-autoload " , Arg . Clear autoload ,
" Disable autoloading of files in $OCAML_TOPLEVEL_PATH/autoload " ;
2014-04-11 15:06:09 +00:00
" -require " , Arg . String ( fun s -> preload := ` Packages ( UTop . split_words s ) :: ! preload ) ,
2013-12-10 15:19:10 +00:00
" <package> Load this package " ;
2014-05-02 15:43:30 +00:00
" -dparsetree " , Arg . Set Clflags . dump_parsetree , " Dump OCaml AST after rewriting " ;
" -dsource " , Arg . Set Clflags . dump_source , " Dump OCaml source after rewriting " ;
2012-02-11 09:21:07 +00:00
]
2013-01-29 20:02:52 +00:00
let () = Clflags . real_paths := false
2012-02-12 19:04:32 +00:00
let app_name = Filename . basename Sys . executable_name
let usage = Printf . sprintf " Usage: %s <options> <object-files> [script-file [arguments]] \n options are: " app_name
2012-02-11 09:21:07 +00:00
2013-11-04 12:58:15 +00:00
let load_init_files dir =
let files = Sys . readdir dir in
Array . sort String . compare files ;
Array . iter
( fun fn ->
if Filename . check_suffix fn " .ml " then
2013-11-26 13:22:36 +00:00
ignore ( Toploop . use_silently Format . err_formatter ( Filename . concat dir fn ) : bool ) )
2013-11-04 12:58:15 +00:00
files
;;
2016-02-23 11:06:52 +00:00
let common_init ~ initial_env =
2012-02-11 09:21:07 +00:00
(* Initializes toplevel environment. *)
2016-02-23 11:06:52 +00:00
( match initial_env with
| None -> Toploop . initialize_toplevel_env ()
| Some env -> Toploop . toplevel_env := env ) ;
2012-02-11 09:21:07 +00:00
(* Set the global input name. *)
Location . input_name := UTop . input_name ;
(* Make sure SIGINT is catched while executing OCaml code. *)
Sys . catch_break true ;
2013-11-04 12:58:15 +00:00
(* Load system init files. *)
( match try Some ( Sys . getenv " OCAML_TOPLEVEL_PATH " ) with Not_found -> None with
| Some dir ->
Topdirs . dir_directory dir ;
2013-11-26 13:48:34 +00:00
let autoload_dir = Filename . concat dir " autoload " in
if ! autoload && ! UTop_private . autoload && Sys . file_exists autoload_dir then
load_init_files autoload_dir
2013-11-04 12:58:15 +00:00
| None -> () ) ;
2012-02-11 09:21:07 +00:00
(* Load user's .ocamlinit file. *)
2012-02-12 20:40:29 +00:00
( match ! Clflags . init_file with
| Some fn ->
if Sys . file_exists fn then
2013-11-04 12:58:15 +00:00
ignore ( Toploop . use_silently Format . err_formatter fn : bool )
2012-02-12 20:40:29 +00:00
else
Printf . eprintf " Init file not found: \" %s \" . \n " fn
| None ->
if Sys . file_exists " .ocamlinit " then
2013-11-04 12:58:15 +00:00
ignore ( Toploop . use_silently Format . err_formatter " .ocamlinit " : bool )
2012-02-12 20:40:29 +00:00
else
let fn = Filename . concat LTerm_resources . home " .ocamlinit " in
if Sys . file_exists fn then
ignore ( Toploop . use_silently Format . err_formatter fn ) ) ;
(* Load history after the initialization file so the user can change
the history file name . * )
2012-02-15 15:49:29 +00:00
Lwt_main . run ( init_history () ) ;
(* Install signal handlers. *)
let behavior = Sys . Signal_handle ( fun signo -> raise ( Term signo ) ) in
let catch signo =
try
Sys . set_signal signo behavior
with _ ->
(* All signals may not be supported on some OS. *)
()
in
(* We lost the terminal. *)
catch Sys . sighup ;
(* Termination request. *)
catch Sys . sigterm
2012-02-11 09:21:07 +00:00
2012-02-12 19:04:32 +00:00
let load_inputrc () =
2014-10-18 16:35:39 +00:00
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 )
2012-02-12 19:04:32 +00:00
2016-02-23 11:06:52 +00:00
let main_aux ~ initial_env =
2012-02-11 09:21:07 +00:00
Arg . parse args file_argument usage ;
if not ( prepare () ) then exit 2 ;
if ! emacs_mode then begin
UTop_private . set_ui UTop_private . Emacs ;
let module Emacs = Emacs ( struct end ) in
Printf . printf " Welcome to utop version %s (using OCaml version %s)! \n \n %! " UTop . version Sys . ocaml_version ;
2016-02-23 11:06:52 +00:00
common_init ~ initial_env ;
2012-02-11 09:21:07 +00:00
Emacs . loop ()
end else begin
UTop_private . set_ui UTop_private . Console ;
let term = Lwt_main . run ( Lazy . force LTerm . stdout ) in
if LTerm . incoming_is_a_tty term && LTerm . outgoing_is_a_tty term then begin
(* Set the initial size. *)
UTop_private . set_size ( S . const ( LTerm . size term ) ) ;
(* Load user data. *)
2014-10-18 16:35:39 +00:00
Lwt_main . run ( Lwt . join [ UTop_styles . load () ; load_inputrc () ] ) ;
2012-02-11 09:21:07 +00:00
(* Display a welcome message. *)
Lwt_main . run ( welcome term ) ;
(* Common initialization. *)
2016-02-23 11:06:52 +00:00
common_init ~ initial_env ;
2012-02-11 09:21:07 +00:00
(* Print help message. *)
print_string " \n Type #utop_help for help about using utop. \n \n " ;
flush stdout ;
(* Main loop. *)
try
loop term
with LTerm_read_line . Interrupt ->
()
end else begin
(* Use the standard toplevel. Just make sure that Lwt threads can
run while reading phrases . * )
Toploop . read_interactive_input := read_input_classic ;
Toploop . loop Format . std_formatter
end
end ;
(* Don't let the standard toplevel run... *)
exit 0
2012-02-12 19:04:32 +00:00
2016-02-23 11:06:52 +00:00
let main_internal ~ initial_env =
2012-02-12 19:04:32 +00:00
try
2016-02-23 11:06:52 +00:00
main_aux ~ initial_env
2012-02-12 19:04:32 +00:00
with exn ->
( match exn with
| Unix . Unix_error ( error , func , " " ) ->
Printf . eprintf " %s: %s: %s \n " app_name func ( Unix . error_message error )
| Unix . Unix_error ( error , func , arg ) ->
Printf . eprintf " %s: %s(%S): %s \n " app_name func arg ( Unix . error_message error )
| exn ->
Printf . eprintf " Fatal error: exception %s \n " ( Printexc . to_string exn ) ) ;
Printexc . print_backtrace stderr ;
flush stderr ;
exit 2
2016-02-23 11:06:52 +00:00
let main () = main_internal ~ initial_env : None
type value = V : string * _ -> value
2017-04-20 12:34:48 +00:00
# if not defined ENABLE_INTERACT
2016-04-25 09:50:26 +00:00
let interact ~ search_path ~ unit ~ loc : ( fname , lnum , cnum , _ ) ~ values =
failwith " \
UTop_main . interact wasn't enabled at compile time .
If you installed utop through opam , just do this to enable this feature :
$ opam install ppx_tools "
2016-04-08 08:31:37 +00:00
# else
2016-02-23 11:06:52 +00:00
exception Found of Env . t
let interact ~ search_path ~ unit ~ loc : ( fname , lnum , cnum , _ ) ~ values =
2016-02-23 11:27:22 +00:00
let cmt_fname =
try
Misc . find_in_path_uncap search_path ( unit ^ " .cmt " )
with Not_found ->
Printf . ksprintf failwith " %s.cmt not found in search path! " fname
in
let cmt_infos = Cmt_format . read_cmt cmt_fname in
2016-02-23 11:06:52 +00:00
let search = object ( self )
inherit [ unit ] UTop_cmt_lifter . lifter as super
method ! lift_Typedtree_expression e =
super # lift_Typedtree_expression e ;
match e . exp_desc with
| Texp_apply ( _ , args ) -> begin
2016-04-08 08:31:37 +00:00
try
match
2016-04-11 19:34:42 +00:00
# if OCAML_VERSION > = ( 4 , 03 , 0 )
List . find ( fun ( lab , _ ) -> lab = Asttypes . Labelled " loc " ) args ,
List . find ( fun ( lab , _ ) -> lab = Asttypes . Labelled " values " ) args
# else
2016-04-08 08:31:37 +00:00
List . find ( fun ( lab , _ , _ ) -> lab = " loc " ) args ,
List . find ( fun ( lab , _ , _ ) -> lab = " values " ) args
2016-04-11 19:34:42 +00:00
# endif
2016-04-08 08:31:37 +00:00
with
2016-04-11 19:34:42 +00:00
# if OCAML_VERSION > = ( 4 , 03 , 0 )
| ( Asttypes . Labelled _ , Some l ) , ( Asttypes . Labelled _ , Some v ) ->
# else
2016-04-08 08:31:37 +00:00
| ( _ , Some l , Required ) , ( _ , Some v , Required ) ->
2016-04-11 19:34:42 +00:00
# endif
2016-04-08 08:31:37 +00:00
let pos = l . exp_loc . loc_start in
if pos . pos_fname = fname &&
pos . pos_lnum = lnum &&
pos . pos_cnum - pos . pos_bol = cnum then
raise ( Found v . exp_env )
| _ -> ()
with Not_found -> ()
2016-02-23 11:06:52 +00:00
end
| _ -> ()
2016-03-11 16:37:46 +00:00
method ! lift_Types_label_description _ = ()
method ! lift_Types_type_declaration _ = ()
2016-02-23 11:06:52 +00:00
method tuple _ = ()
method string _ = ()
method record _ _ = ()
method nativeint _ = ()
method list _ = ()
method lift_Types_Vars_t _ _ = ()
method lift_Types_Variance_t _ = ()
method lift_Types_Meths_t _ _ = ()
method lift_Types_Concr_t _ = ()
method lift_Env_t _ = ()
method int64 _ = ()
method int32 _ = ()
method int _ = ()
method constr _ _ = ()
method char _ = ()
method array _ = ()
end in
2016-04-08 08:31:37 +00:00
try
search # lift_Cmt_format_cmt_infos cmt_infos ;
failwith " Couldn't find location in cmt file "
with Found env ->
try
List . iter Topdirs . dir_directory ( search_path @ cmt_infos . cmt_loadpath ) ;
let env = Envaux . env_of_only_summary env in
List . iter ( fun ( V ( name , v ) ) -> Toploop . setvalue name ( Obj . repr v ) ) values ;
main_internal ~ initial_env : ( Some env )
with exn ->
Location . report_exception Format . err_formatter exn ;
exit 2
2016-02-24 11:03:51 +00:00
let () =
Location . register_error_of_exn
( function
| Envaux . Error err ->
Some ( Location . error_of_printer_file Envaux . report_error err )
| _ -> None
)
2016-04-08 08:31:37 +00:00
# endif