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
open Lwt_react
open LTerm_text
open LTerm_geom
open UTop_token
open UTop_styles
open UTop_private
module String_set = Set . Make ( String )
(* +-----------------------------------------------------------------+
| History |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
let init_history () =
(* Save history on exit. *)
2012-02-12 19:37:12 +00:00
Lwt_main . at_exit
( fun () ->
match ! UTop . history_file_name with
| 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 ) ) ;
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 ->
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 )
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 |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
let parse_and_check input eos_is_error =
match ! UTop . parse_toplevel_phrase input eos_is_error with
| UTop . Error ( locs , msg ) ->
UTop . Error ( convert_locs input locs , " Error: " ^ msg ^ " \n " )
| UTop . Value phrase ->
match UTop . check_phrase phrase with
| None ->
UTop . Value phrase
| Some ( locs , msg ) ->
UTop . Error ( convert_locs input locs , msg )
(* Read a phrase. If the result is a value, it is guaranteed to by a
valid phrase ( i . e . typable and compilable ) . * )
class read_phrase ~ term = object ( self )
2012-02-12 19:04:32 +00:00
inherit [ Parsetree . toplevel_phrase UTop . result ] LTerm_read_line . engine ~ history : ( LTerm_history . contents UTop . history ) () as super
2012-02-11 09:21:07 +00:00
inherit [ Parsetree . toplevel_phrase UTop . result ] LTerm_read_line . term term as super_term
val mutable return_value = None
method eval =
match return_value with
| Some x ->
x
| None ->
assert false
method exec = function
| LTerm_read_line . Accept :: actions when ! UTop . smart_accept && S . value self # mode = LTerm_read_line . Edition -> begin
Zed_macro . add self # macro LTerm_read_line . Accept ;
(* Try to parse the input. *)
let input = Zed_rope . to_string ( Zed_edit . text self # edit ) in
(* Toploop does that: *)
Location . reset () ;
try
let result = parse_and_check input false in
return_value <- Some result ;
2012-02-12 19:04:32 +00:00
LTerm_history . add UTop . history input ;
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 ->
super_term # exec actions
method stylise last =
let styled , position = super # stylise last in
(* Syntax highlighting *)
let stylise start stop token_style =
for i = start to stop - 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 ~ camlp4 : ( UTop . get_camlp4 () ) ( LTerm_text . to_string styled ) ) ;
if not last then
(* Parenthesis matching. *)
LTerm_text . stylise_parenthesis styled position styles . style_paren
else begin
match return_value with
| Some ( UTop . Error ( locs , _ ) ) ->
(* Highlight error locations. *)
List . iter
( fun ( start , stop ) ->
for i = start to stop - 1 do
let ch , style = styled . ( i ) in
styled . ( i ) <- ( ch , { style with LTerm_style . underline = Some true } )
done )
locs
| _ ->
()
end ;
( styled , position )
method completion =
let pos , words = UTop_complete . complete ( Zed_rope . to_string self # input_prev ) in
self # set_completion pos words
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 |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
let print_out_phrase term printer pp out_phrase =
flush stdout ;
flush stderr ;
( match out_phrase with
| Outcometree . Ophr_exception _ ->
if Printexc . backtrace_status () then begin
Printexc . print_backtrace stdout ;
flush stdout
end
| _ ->
() ) ;
let buffer = Buffer . create 1024 in
let pp = Format . formatter_of_buffer buffer in
Format . pp_set_margin pp ( LTerm . size term ) . cols ;
printer pp out_phrase ;
Format . pp_print_flush pp () ;
let string = Buffer . contents buffer in
let styled = LTerm_text . of_string string in
let stylise start stop token_style =
for i = start to stop - 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 string ) ;
Lwt_main . run ( LTerm . fprints term styled )
(* +-----------------------------------------------------------------+
| Lwt_main . run auto - insertion |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
let longident_lwt_main_run = Longident . Ldot ( Longident . Lident " Lwt_main " , " run " )
let is_eval = function
| { Parsetree . pstr_desc = Parsetree . Pstr_eval _ } -> true
| _ -> false
let insert_lwt_main_run phrase =
match phrase with
| Parsetree . Ptop_def pstr ->
let env = ! Toploop . toplevel_env in
let lwt_main_run_is_the_real_one =
try
match Env . lookup_value longident_lwt_main_run env with
| Path . Pdot ( Path . Pident id , " run " , 0 ) , _ ->
Ident . persistent id
| _ ->
false
with Not_found ->
false
in
if lwt_main_run_is_the_real_one && List . exists is_eval pstr then
let tstr , _ , _ = Typemod . type_structure env pstr Location . none in
Parsetree . Ptop_def
( List . map2
( fun pstr_item tstr_item ->
match pstr_item , tstr_item with
| { Parsetree . pstr_desc = Parsetree . Pstr_eval e ; Parsetree . pstr_loc = loc } ,
Typedtree . Tstr_eval {
Typedtree . exp_type = {
Types . desc =
Types . Tconstr ( Path . Pdot ( Path . Pident id , " t " , - 1 ) , _ , _ )
}
} ->
if Ident . persistent id && Ident . name id = " Lwt " then {
Parsetree . pstr_desc =
Parsetree . Pstr_eval {
Parsetree . pexp_desc =
Parsetree . Pexp_apply
( { Parsetree . pexp_desc = Parsetree . Pexp_ident longident_lwt_main_run ; Parsetree . pexp_loc = loc } ,
[ ( " " , e ) ] ) ;
Parsetree . pexp_loc = loc ;
} ;
Parsetree . pstr_loc = loc ;
} else
pstr_item
| _ ->
pstr_item )
pstr tstr )
else
phrase
| Parsetree . Ptop_dir _ ->
phrase
(* +-----------------------------------------------------------------+
| Main loop |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
let rec read_phrase term =
try_lwt
( new read_phrase ~ term ) # run
with Sys . Break ->
lwt () = LTerm . fprintl term " Interrupted. " in
read_phrase term
let update_margin pp cols =
if Format . pp_get_margin pp () < > cols then
Format . pp_set_margin pp cols
let print_error msg =
lwt term = Lazy . force LTerm . stdout in
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 . 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 (
try_lwt
match_lwt read_phrase term with
| UTop . Value phrase ->
return ( Some phrase )
| UTop . Error ( _ , msg ) ->
lwt () = print_error msg in
return None
finally
LTerm . flush term
)
in
match phrase_opt with
| Some phrase ->
(* Add Lwt_main.run to toplevel evals. *)
let phrase = if UTop . get_auto_run_lwt () then insert_lwt_main_run phrase else phrase in
(* Set the margin of standard formatters. *)
let cols = ( LTerm . size term ) . cols in
update_margin Format . std_formatter cols ;
update_margin Format . err_formatter cols ;
(* No exception can be raised at this stage. *)
ignore ( Toploop . execute_phrase true Format . std_formatter phrase ) ;
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. *)
lwt () = LTerm . print_box term matrix in
(* Move to after the box. *)
lwt () = LTerm . fprint term " \n " in
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 ->
buffer . [ i ] <- c ;
if c = '\n' then
return ( i + 1 , false )
else
loop ( i + 1 )
| None ->
return ( i , true )
in
Lwt_main . run ( Lwt_io . write Lwt_io . stdout prompt > > loop 0 )
(* +-----------------------------------------------------------------+
| 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
2012-02-12 20:40:29 +00:00
let process_input add_to_history eos_is_error =
let input = read_data () in
match parse_and_check input eos_is_error with
2012-02-11 09:21:07 +00:00
| UTop . Value phrase ->
send " accept " " " ;
2012-02-12 20:40:29 +00:00
if add_to_history then LTerm_history . add UTop . history input ;
2012-02-11 09:21:07 +00:00
(* Add Lwt_main.run to toplevel evals. *)
let phrase = if UTop . get_auto_run_lwt () then insert_lwt_main_run phrase else phrase in
(* No exception can be raised at this stage. *)
ignore ( Toploop . execute_phrase true Format . std_formatter phrase )
| UTop . Error ( locs , msg ) ->
send " accept " ( String . concat " , " ( List . map ( fun ( a , b ) -> Printf . sprintf " %d,%d " a b ) locs ) ) ;
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
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 ()
| Some ( " complete " , _ ) ->
2012-02-12 20:40:29 +00:00
let input = read_data () in
2012-02-11 09:21:07 +00:00
let start , words = UTop_complete . complete input in
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-11 09:21:07 +00:00
| Some ( command , _ ) ->
Printf . ksprintf ( send " stderr " ) " unrecognized command %S! " command ;
exit 1
end
(* +-----------------------------------------------------------------+
| Entry point |
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + * )
let emacs_mode = ref false
let preload_objects = ref []
let prepare () =
Toploop . set_paths () ;
try
let res = List . for_all ( Topdirs . load_file Format . err_formatter ) ( List . rev ! preload_objects ) in
! Toploop . toplevel_startup_hook () ;
res
with exn ->
try
Errors . report_error Format . err_formatter exn ;
false
with exn ->
Format . eprintf " Uncaught exception: %s \n " ( Printexc . to_string exn ) ;
false
let read_script_from_stdin () =
let args = Array . sub Sys . argv ! Arg . current ( Array . length Sys . argv - ! Arg . current ) in
if prepare () && Toploop . run_script Format . err_formatter " " args then
exit 0
else
exit 2
let file_argument name =
if Filename . check_suffix name " .cmo " | | Filename . check_suffix name " .cma " then
preload_objects := name :: ! preload_objects
else begin
let args = Array . sub Sys . argv ! Arg . current ( Array . length Sys . argv - ! Arg . current ) in
if prepare () && Toploop . run_script Format . err_formatter name args then
exit 0
else
exit 2
end
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
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 " ;
" -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 " ;
" -principal " , Arg . Set Clflags . principal , " Check principality of type inference " ;
" -rectypes " , Arg . Set Clflags . recursive_types , " Allow arbitrary recursive types " ;
" -stdin " , Arg . Unit read_script_from_stdin , " Read script from standard input " ;
" -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 " ;
]
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
let common_init () =
(* Initializes toplevel environment. *)
Toploop . initialize_toplevel_env () ;
(* Set the global input name. *)
Location . input_name := UTop . input_name ;
(* Make sure SIGINT is catched while executing OCaml code. *)
Sys . catch_break true ;
(* 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
ignore ( Toploop . use_silently Format . err_formatter fn )
else
Printf . eprintf " Init file not found: \" %s \" . \n " fn
| None ->
if Sys . file_exists " .ocamlinit " then
ignore ( Toploop . use_silently Format . err_formatter " .ocamlinit " )
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 . * )
Lwt_main . run ( init_history () )
2012-02-11 09:21:07 +00:00
2012-02-12 19:04:32 +00:00
let load_inputrc () =
try_lwt
LTerm_inputrc . load ()
with Unix . Unix_error ( error , func , arg ) ->
Lwt_log . error_f " cannot key bindings from %S: %s: %s " LTerm_inputrc . default func ( Unix . error_message error )
let main_aux () =
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 ;
common_init () ;
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 ) ) ;
(* Install our out phrase printer. *)
Toploop . print_out_phrase := print_out_phrase term ! Toploop . print_out_phrase ;
(* Load user data. *)
2012-02-12 19:37:12 +00:00
Lwt_main . run ( 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. *)
common_init () ;
(* 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
let main () =
try
main_aux ()
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