diff --git a/src/base/config.ml b/src/base/config.ml index 9ddbe51..7e8f3d7 100644 --- a/src/base/config.ml +++ b/src/base/config.ml @@ -27,7 +27,7 @@ let set (config : 'a t) (value : 'a) : unit = | Constant -> failwith "invalid update to locked config" let ( ! ) (config : 'a t) : 'a = get config -let ( $= ) (config : 'a t) (value : 'a) = set config value +let ( := ) (config : 'a t) (value : 'a) = set config value (* Generic platform configurations *) let dflt_buf_sz : int t = constant 512 diff --git a/src/base/console.ml b/src/base/console.ml index d537992..f361f5b 100644 --- a/src/base/console.ml +++ b/src/base/console.ml @@ -39,8 +39,8 @@ let get_system () : system = module Config = struct include Config - let colored_requirement : int t = constant 256 - let system : system t = constant (get_system ()) + let colored_requirement = constant 256 + let system = constant (get_system ()) end let pwd () : string = Unix.getcwd () diff --git a/src/base/dune b/src/base/dune index 3d62311..4f5ef2b 100644 --- a/src/base/dune +++ b/src/base/dune @@ -10,7 +10,6 @@ fun option result - json config generator console @@ -18,5 +17,6 @@ writer font log + json time) (libraries unix fpath yojson)) diff --git a/src/base/font.ml b/src/base/font.ml index 53c2042..7396899 100644 --- a/src/base/font.ml +++ b/src/base/font.ml @@ -1,7 +1,7 @@ module Config = struct include Config - let colored : bool t = static true + let colored = static true end module Attr = struct @@ -78,71 +78,71 @@ module Attr = struct | `Reset -> 0 | `Foreground fg -> to_code fg | `Background bg -> to_code bg + 10 - | `Effect eff -> to_code eff - | `Style sty -> to_code sty + | `Effect effect -> to_code effect + | `Style style -> to_code style end type t = Attr.t list open struct - let make_foreground (fg : Attr.color option) (font : t) : t = - Option.fold ~none:font ~some:(fun fg -> `Foreground fg :: font) fg + let mk_foreground (fg : Attr.color option) (font : t) : t = + Option.fold ~none:font ~some:(fun fg' -> `Foreground fg' :: font) fg - let make_background (bg : Attr.color option) (font : t) : t = + let mk_background (bg : Attr.color option) (font : t) : t = Option.fold ~none:font ~some:(fun bg -> `Background bg :: font) bg - let make_effect (eff : Attr.effect option) (font : t) : t = - Option.fold ~none:font ~some:(fun eff -> `Effect eff :: font) eff + let mk_effect (effect : Attr.effect option) (font : t) : t = + Option.fold ~none:font ~some:(fun effect' -> `Effect effect' :: font) effect - let make_style ((sty, on) : Attr.style * bool option) (font : t) : t = - let style_f = function true -> `Style sty :: font | false -> font in + let mk_style ((style, on) : Attr.style * bool option) (font : t) : t = + let style_f = function true -> `Style style :: font | false -> font in Option.fold ~none:font ~some:style_f on - let make_font (fg : Attr.color option) (bg : Attr.color option) - (eff : Attr.effect option) (bold : bool option) (italic : bool option) - (underline : bool option) (strike : bool option) = - make_foreground fg [] - |> make_background bg - |> make_effect eff - |> make_style (`Bold, bold) - |> make_style (`Italic, italic) - |> make_style (`Underline, underline) - |> make_style (`Strike, strike) + let mk_font (fg : Attr.color option) (bg : Attr.color option) + (effect : Attr.effect option) (bold : bool option) (italic : bool option) + (underline : bool option) (strike : bool option) : t = + mk_foreground fg [] + |> mk_background bg + |> mk_effect effect + |> mk_style (`Bold, bold) + |> mk_style (`Italic, italic) + |> mk_style (`Underline, underline) + |> mk_style (`Strike, strike) end let colored (writer : Writer.t) : bool = Config.(!colored) && Writer.colored writer -let foreground (font : t) : Attr.color option = +let get_foreground (font : t) : Attr.color option = List.find_map (function `Foreground fg -> Some fg | _ -> None) font -let background (font : t) : Attr.color option = +let get_background (font : t) : Attr.color option = List.find_map (function `Background bg -> Some bg | _ -> None) font -let effect (font : t) : Attr.effect option = - List.find_map (function `Effect eff -> Some eff | _ -> None) font +let get_effect (font : t) : Attr.effect option = + List.find_map (function `Effect effect -> Some effect | _ -> None) font -let style (sty : Attr.style) (font : t) : bool option = +let get_style (style : Attr.style) (font : t) : bool option = Fun.flip List.find_map font (function - | `Style sty' when sty == sty' -> Some true + | `Style style' when style == style' -> Some true | _ -> None ) let create ?(fg : Attr.color option) ?(bg : Attr.color option) - ?(eff : Attr.effect option) ?(bold : bool option) ?(italic : bool option) + ?(effect : Attr.effect option) ?(bold : bool option) ?(italic : bool option) ?(underline : bool option) ?(strike : bool option) () : t = - make_font fg bg eff bold italic underline strike + mk_font fg bg effect bold italic underline strike let update ?(fg : Attr.color option) ?(bg : Attr.color option) - ?(eff : Attr.effect option) ?(bold : bool option) ?(italic : bool option) + ?(effect : Attr.effect option) ?(bold : bool option) ?(italic : bool option) ?(underline : bool option) ?(strike : bool option) (font : t) : t = - let fg = Option.map_none ~value:(foreground font) fg in - let bg = Option.map_none ~value:(background font) bg in - let effect = Option.map_none ~value:(effect font) eff in - let bold = Option.map_none ~value:(style `Bold font) bold in - let italic = Option.map_none ~value:(style `Italic font) italic in - let underline = Option.map_none ~value:(style `Underline font) underline in - let strike = Option.map_none ~value:(style `Strike font) strike in - make_font fg bg effect bold italic underline strike + let fg = Option.map_none ~value:(get_foreground font) fg in + let bg = Option.map_none ~value:(get_background font) bg in + let effect = Option.map_none ~value:(get_effect font) effect in + let bold = Option.map_none ~value:(get_style `Bold font) bold in + let italic = Option.map_none ~value:(get_style `Italic font) italic in + let underline = Option.map_none ~value:(get_style `Underline font) underline in + let strike = Option.map_none ~value:(get_style `Strike font) strike in + mk_font fg bg effect bold italic underline strike let pp_font (ppf : Fmt.t) (font : t) : unit = let pp_attr ppf attr = Fmt.pp_int ppf (Attr.code attr) in @@ -152,18 +152,18 @@ let pp (font : t) (pp_v : Fmt.t -> 'a -> unit) (ppf : Fmt.t) (v : 'a) : unit = if not (colored (Writer.find ppf)) then pp_v ppf v else Fmt.fmt ppf "%a%a%a" pp_font font pp_v v pp_font [ `Reset ] -let kfmt (font : t) (k : Fmt.t -> 'a) (ppf : Fmt.t) : - ('b, Fmt.t, unit, 'a) format4 -> 'b = +let kfmt (font : t) (k : Fmt.t -> 'a) (ppf : Fmt.t) + (fmt : ('b, Fmt.t, unit, 'a) format4) : 'b = let pp_fmt ppf = Fmt.fmt ppf "%t" in - Fmt.kdly (fun acc -> pp font pp_fmt ppf acc |> fun () -> k ppf) + Fmt.kdly (fun acc -> pp font pp_fmt ppf acc |> fun () -> k ppf) fmt -let kdly (font : t) (k : (Fmt.t -> unit) -> 'a) : - ('b, Fmt.t, unit, 'a) format4 -> 'b = +let kdly (font : t) (k : (Fmt.t -> unit) -> 'a) + (fmt : ('b, Fmt.t, unit, 'a) format4) : 'b = let pp_fmt ppf = Fmt.fmt ppf "%t" in - Fmt.kdly (fun acc -> k (fun ppf -> pp font pp_fmt ppf acc)) + Fmt.kdly (fun acc -> k (fun ppf -> pp font pp_fmt ppf acc)) fmt -let fmt (font : t) (ppf : Fmt.t) : ('a, Fmt.t, unit, unit) format4 -> 'a = - kfmt font ignore ppf +let fmt (font : t) (ppf : Fmt.t) (fmt : ('a, Fmt.t, unit, unit) format4) : 'a = + kfmt font ignore ppf fmt -let dly (font : t) : ('a, Fmt.t, unit, Fmt.t -> unit) format4 -> 'a = - kdly font Fun.id +let dly (font : t) (fmt : ('a, Fmt.t, unit, Fmt.t -> unit) format4) : 'a = + kdly font Fun.id fmt diff --git a/src/base/generator.ml b/src/base/generator.ml index 62c1759..e3c7031 100644 --- a/src/base/generator.ml +++ b/src/base/generator.ml @@ -4,12 +4,12 @@ type 'a t = } open struct - let next (gen : int ref) (step : int) () = + let next (gen : int ref) (step : int) () : int = let counter = !gen in gen := counter + step; counter - let reset (counter : int ref) (init : int) () = counter := init + let reset (counter : int ref) (init : int) () : unit = counter := init end let of_numbers ?(init : int = 0) ?(step : int = 1) () : int t = diff --git a/src/base/stdlib/json.ml b/src/base/json.ml similarity index 100% rename from src/base/stdlib/json.ml rename to src/base/json.ml diff --git a/src/base/log.ml b/src/base/log.ml index 657c956..ee42b27 100644 --- a/src/base/log.ml +++ b/src/base/log.ml @@ -1,32 +1,22 @@ module Config = struct include Config - let log_warns : bool t = static true - let log_infos : bool t = static false - let log_debugs : bool t = static false - let log_verbose : bool t = static false - - let app : ((Fmt.t -> unit) * Font.t) t = - constant (Fmt.dly "graphjs", Font.create ~fg:`White ()) - - let error : ((Fmt.t -> unit) * Font.t) t = - constant (Fmt.dly "error", Font.create ~fg:`LightRed ()) - - let warn : ((Fmt.t -> unit) * Font.t) t = - constant (Fmt.dly "warn", Font.create ~fg:`Yellow ()) - - let info : ((Fmt.t -> unit) * Font.t) t = - constant (Fmt.dly "info", Font.create ~fg:`LightCyan ()) - - let debug : ((Fmt.t -> unit) * Font.t) t = - constant (Fmt.dly "debug", Font.create ~fg:`Cyan ()) + let log_warns = static true + let log_infos = static false + let log_debugs = static false + let log_verbose = static false + let app = constant (Fmt.dly "graphjs", Font.create ~fg:`White ()) + let error = constant (Fmt.dly "error", Font.create ~fg:`LightRed ()) + let warn = constant (Fmt.dly "warn", Font.create ~fg:`Yellow ()) + let info = constant (Fmt.dly "info", Font.create ~fg:`LightCyan ()) + let debug = constant (Fmt.dly "debug", Font.create ~fg:`Cyan ()) end open struct - let create_log ((header, font) : (Fmt.t -> unit) * Font.t) (ppf : Fmt.t) : - ('a, Fmt.t, unit, 'b) format4 -> 'a = + let create_log ((header, font) : (Fmt.t -> unit) * Font.t) (ppf : Fmt.t) + (fmt : ('a, Fmt.t, unit, 'b) format4) : 'a = let pp_content ppf fmt = Font.fmt font ppf "[%t] %t" header fmt in - Fmt.kdly (Fmt.fmt ppf "%a@." pp_content) + Fmt.kdly (Fmt.fmt ppf "%a@." pp_content) fmt end let fmt_app (ppf : Fmt.t) (fmt : ('a, Fmt.t, unit, unit) format4) : 'a = @@ -96,7 +86,7 @@ module Redirect = struct } let capture (old : Writer.t Config.t) (buf : Buffer.t) : Buffer.t = - Writer.Config.(old $= Writer.to_buffer buf); + Writer.Config.(old := Writer.to_buffer buf); buf let capture_to ~(out : Buffer.t option) ~(err : Buffer.t option) : t = @@ -115,7 +105,7 @@ module Redirect = struct | Shared -> let streams = capture_to ~out:(buffer ()) ~err:None in let new_out = Writer.Config.(!stdout) in - Writer.Config.(stderr $= new_out); + Writer.Config.(stderr := new_out); streams let pp_captured (ppf : Fmt.t) (streams : t) : unit = @@ -133,6 +123,6 @@ module Redirect = struct let new_err = Writer.Config.(!stderr) in Option.fold ~none:() ~some:(close new_out old_out.ppf) streams.new_out; Option.fold ~none:() ~some:(close new_err old_err.ppf) streams.new_err; - Writer.Config.(stdout $= old_out); - Writer.Config.(stderr $= old_err) + Writer.Config.(stdout := old_out); + Writer.Config.(stderr := old_err) end diff --git a/src/base/stdlib/option.ml b/src/base/stdlib/option.ml index daef3d0..657c982 100644 --- a/src/base/stdlib/option.ml +++ b/src/base/stdlib/option.ml @@ -1,16 +1,13 @@ include Stdlib.Option -let ( let* ) (v : 'a t) (f : 'a -> 'b t) : 'b t = bind v f -let ( let+ ) (f : 'a -> 'b) (v : 'a t) : 'b t = map f v +let ( let* ) (o : 'a t) (f : 'a -> 'b t) : 'b t = bind o f +let ( let+ ) (f : 'a -> 'b) (o : 'a t) : 'b t = map f o -let value_lazy ~(default : 'a lazy_t) : 'a t -> 'a = function - | None -> Lazy.force default - | Some v -> v +let value_lazy ~(default : 'a lazy_t) (o : 'a t) : 'a = + match o with None -> Lazy.force default | Some v -> v -let map_none ~(value : 'a t) : 'a t -> 'a t = function - | None -> value - | Some _ as v -> v +let map_none ~(value : 'a t) (o : 'a t) : 'a t = + match o with None -> value | Some _ as v -> v -let fold_lazy ~(none : 'b lazy_t) ~(some : 'a -> 'b) : 'a t -> 'b = function - | None -> Lazy.force none - | Some v -> some v +let fold_lazy ~(none : 'b lazy_t) ~(some : 'a -> 'b) (o : 'a t) : 'b = + match o with None -> Lazy.force none | Some v -> some v diff --git a/src/base/stdlib/result.ml b/src/base/stdlib/result.ml index fc61ceb..ce73433 100644 --- a/src/base/stdlib/result.ml +++ b/src/base/stdlib/result.ml @@ -1,11 +1,11 @@ include Stdlib.Result -let ( let* ) (v : ('a, 'e) t) (f : 'a -> ('b, 'e) t) : ('b, 'e) t = bind v f -let ( let+ ) (f : 'a -> 'b) (v : ('a, 'e) t) : ('b, 'e) t = map f v +let ( let* ) (r : ('a, 'e) t) (f : 'a -> ('b, 'e) t) : ('b, 'e) t = bind r f +let ( let+ ) (f : 'a -> 'b) (r : ('a, 'e) t) : ('b, 'e) t = map f r -let extract (vs : ('a, 'b) t list) : ('a list, 'b) t = - Fun.flip2 List.fold_right vs (Ok []) (fun v acc -> - match (acc, v) with +let extract (rs : ('a, 'b) t list) : ('a list, 'b) t = + Fun.flip2 List.fold_right rs (Ok []) (fun r acc -> + match (acc, r) with | ((Error _ as err), _) -> err | (Ok _, (Error _ as err)) -> err | (Ok vs, Ok v) -> Ok (v :: vs) ) diff --git a/src/client/bulk.ml b/src/client/bulk.ml index ff4f8a9..16d92b8 100644 --- a/src/client/bulk.ml +++ b/src/client/bulk.ml @@ -3,7 +3,7 @@ open Graphjs_base module Config = struct include Config - let time_font_f font = Font.update font ~eff:`Faint + let time_font_f font = Font.update font ~effect:`Faint let main_font : Font.t t = constant (Font.create ~fg:`White ()) let path_font : Font.t t = constant (Font.create ~fg:`DarkGray ()) let success_font : Font.t t = constant (Font.create ~fg:`LightGreen ()) diff --git a/src/client/commands/cmd_mdg.ml b/src/client/commands/cmd_mdg.ml index 890971d..9fc4ace 100644 --- a/src/client/commands/cmd_mdg.ml +++ b/src/client/commands/cmd_mdg.ml @@ -13,8 +13,8 @@ module Options = struct } let set (no_svg : bool) (no_literal_wrapping : bool) () : unit = - Builder_config.(export_svg $= not no_svg); - Builder_config.(wrap_literal_property_updates $= not no_literal_wrapping) + Builder_config.(export_svg := not no_svg); + Builder_config.(wrap_literal_property_updates := not no_literal_wrapping) let set_cmd (inputs : Fpath.t list) (output : Fpath.t option) (taint_config' : Fpath.t option) () : t = diff --git a/src/client/commands/cmd_parse.ml b/src/client/commands/cmd_parse.ml index 5cd7600..fbd9927 100644 --- a/src/client/commands/cmd_parse.ml +++ b/src/client/commands/cmd_parse.ml @@ -10,7 +10,7 @@ module Options = struct } let set (test262_conform_hoisted' : bool) : unit = - Parser_config.(test262_conform_hoisted $= test262_conform_hoisted') + Parser_config.(test262_conform_hoisted := test262_conform_hoisted') let set_cmd (inputs : Fpath.t list) (output : Fpath.t option) () : t = { inputs; output } diff --git a/src/graphjs.ml b/src/graphjs.ml index b5de8e1..851462d 100644 --- a/src/graphjs.ml +++ b/src/graphjs.ml @@ -6,12 +6,12 @@ type status = (unit Exec.status Cmd.eval_ok, Cmd.eval_error) Result.t let set_copts (colorless : bool) (lvl : Enums.DebugLvl.t) (verbose : bool) (override' : bool) : unit = - Font.Config.(colored $= not colorless); - Log.Config.(log_warns $= (lvl >= Warn)); - Log.Config.(log_infos $= (verbose || lvl >= Info)); - Log.Config.(log_debugs $= (lvl >= All)); - Log.Config.(log_verbose $= verbose); - Workspace.Config.(override $= override') + Font.Config.(colored := not colorless); + Log.Config.(log_warns := (lvl >= Warn)); + Log.Config.(log_infos := (verbose || lvl >= Info)); + Log.Config.(log_debugs := (lvl >= All)); + Log.Config.(log_verbose := verbose); + Workspace.Config.(override := override') let copts : unit Term.t = let open Term in @@ -23,7 +23,7 @@ let copts : unit Term.t = let set_shared_opts (mode' : Enums.AnalysisMode.t) () : unit = let open Graphjs_share in - Share_config.(mode $= Enums.AnalysisMode.conv mode') + Share_config.(mode := Enums.AnalysisMode.conv mode') let shared_opts : unit Term.t = Term.(const set_shared_opts $ Docs.SharedOpts.mode $ copts)