haskal
/
utop
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Get rid of lwt.syntax.

This commit is contained in:
Peter Zotov 2014-10-18 20:35:39 +04:00
parent 257bfa7eb6
commit 121b1a9e58
5 changed files with 95 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
_oasis
View File

@ -45,7 +45,7 @@ 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
@ -65,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"
@ -73,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)
# +-------------------------------------------------------------------+

3
_tags
View File

@ -1,8 +1,5 @@
# -*- conf -*-
# Use camlp4 on all files
<**/*.ml>: syntax_camlp4o, pkg_lwt.syntax
# Use compiler interfaces
<src/**/*.ml{,i}>: use_compiler_libs

10
src/lib/uTop.cppo.ml
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
@ -595,10 +597,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

91
src/lib/uTop_main.cppo.ml
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 |
@ -553,20 +561,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 +592,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
@ -677,10 +687,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
@ -707,7 +717,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 |
@ -1272,13 +1282,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 +1307,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. *)

67
src/lib/uTop_styles.ml
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