diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 97bb86e2..c1371cdb 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -50,6 +50,9 @@ jobs: - name: Install dependencies run: opam install . --deps-only + - name: Check format + run: opam exec -- dune build @fmt + - name: Build executables run: opam exec -- dune build diff --git a/benchmarks/Benchmark.ml b/benchmarks/Benchmark.ml index 0ce5662a..f4ea6b5f 100644 --- a/benchmarks/Benchmark.ml +++ b/benchmarks/Benchmark.ml @@ -4,8 +4,8 @@ module CommentTable = Res_comments_table module Parser = Res_parser module Printer = Res_printer -module IO: sig - val readFile: string -> string +module IO : sig + val readFile : string -> string end = struct (* random chunk size: 2^15, TODO: why do we guess randomly? *) let chunkSize = 32768 @@ -15,39 +15,40 @@ end = struct let buffer = Buffer.create chunkSize in let chunk = (Bytes.create [@doesNotRaise]) chunkSize in let rec loop () = - let len = try input chan chunk 0 chunkSize with Invalid_argument _ -> 0 in + let len = + try input chan chunk 0 chunkSize with Invalid_argument _ -> 0 + in if len == 0 then ( close_in_noerr chan; - Buffer.contents buffer - ) else ( + Buffer.contents buffer) + else ( Buffer.add_subbytes buffer chunk 0 len; - loop () - ) + loop ()) in loop () end -module Time: sig +module Time : sig type t - val now: unit -> t + val now : unit -> t - val toUint64: t -> int64 [@@live] + val toUint64 : t -> int64 [@@live] (* let of_uint64_ns ns = ns *) - val nanosecond: t [@@live] - val microsecond: t [@@live] - val millisecond: t [@@live] - val second: t [@@live] - val minute: t [@@live] - val hour: t [@@live] + val nanosecond : t [@@live] + val microsecond : t [@@live] + val millisecond : t [@@live] + val second : t [@@live] + val minute : t [@@live] + val hour : t [@@live] - val zero: t + val zero : t - val diff: t -> t -> t - val add: t -> t -> t - val print: t -> float + val diff : t -> t -> t + val add : t -> t -> t + val print : t -> float end = struct (* nanoseconds *) type t = int64 @@ -64,22 +65,21 @@ end = struct let hour = Int64.mul 60L minute (* TODO: we could do this inside caml_absolute_time *) - external init: unit -> unit = "caml_mach_initialize" - let () = init() - external now: unit -> t = "caml_mach_absolute_time" + external init : unit -> unit = "caml_mach_initialize" + let () = init () + external now : unit -> t = "caml_mach_absolute_time" let diff t1 t2 = Int64.sub t2 t1 let add t1 t2 = Int64.add t1 t2 - let print t = - (Int64.to_float t) *. 1e-6 + let print t = Int64.to_float t *. 1e-6 end -module Benchmark: sig +module Benchmark : sig type t - val make: name:string -> f:(t -> unit) -> unit -> t - val launch: t -> unit - val report: t -> unit + val make : name:string -> f:(t -> unit) -> unit -> t + val launch : t -> unit + val report : t -> unit end = struct type t = { name: string; @@ -89,7 +89,7 @@ end = struct benchFunc: t -> unit; mutable timerOn: bool; (* mutable result: benchmarkResult; *) - (* The initial states *) + (* The initial states *) mutable startAllocs: float; mutable startBytes: float; (* The net total of this test after being run. *) @@ -100,65 +100,69 @@ end = struct let report b = print_endline (Format.sprintf "Benchmark: %s" b.name); print_endline (Format.sprintf "Nbr of iterations: %d" b.n); - print_endline (Format.sprintf "Benchmark ran during: %fms" (Time.print b.duration)); - print_endline (Format.sprintf "Avg time/op: %fms" ((Time.print b.duration) /. (float_of_int b.n))); - print_endline (Format.sprintf "Allocs/op: %d" (int_of_float (b.netAllocs /. (float_of_int b.n)))); - print_endline (Format.sprintf "B/op: %d" (int_of_float (b.netBytes /. (float_of_int b.n)))); - (* return (float64(r.Bytes) * float64(r.N) / 1e6) / r.T.Seconds() *) - + print_endline + (Format.sprintf "Benchmark ran during: %fms" (Time.print b.duration)); + print_endline + (Format.sprintf "Avg time/op: %fms" + (Time.print b.duration /. float_of_int b.n)); + print_endline + (Format.sprintf "Allocs/op: %d" + (int_of_float (b.netAllocs /. float_of_int b.n))); + print_endline + (Format.sprintf "B/op: %d" + (int_of_float (b.netBytes /. float_of_int b.n))); - print_newline(); + (* return (float64(r.Bytes) * float64(r.N) / 1e6) / r.T.Seconds() *) + print_newline (); () - let make ~name ~f () = { - name; - start = Time.zero; - n = 0; - benchFunc = f; - duration = Time.zero; - timerOn = false; - startAllocs = 0.; - startBytes = 0.; - netAllocs = 0.; - netBytes = 0.; - } + let make ~name ~f () = + { + name; + start = Time.zero; + n = 0; + benchFunc = f; + duration = Time.zero; + timerOn = false; + startAllocs = 0.; + startBytes = 0.; + netAllocs = 0.; + netBytes = 0.; + } (* total amount of memory allocated by the program since it started in words *) let mallocs () = - let stats = Gc.quick_stat() in + let stats = Gc.quick_stat () in stats.minor_words +. stats.major_words -. stats.promoted_words let startTimer b = if not b.timerOn then ( - let allocatedWords = mallocs() in + let allocatedWords = mallocs () in b.startAllocs <- allocatedWords; b.startBytes <- allocatedWords *. 8.; - b.start <- Time.now(); - b.timerOn <- true - ) + b.start <- Time.now (); + b.timerOn <- true) let stopTimer b = if b.timerOn then ( - let allocatedWords = mallocs() in - let diff = (Time.diff b.start (Time.now())) in + let allocatedWords = mallocs () in + let diff = Time.diff b.start (Time.now ()) in b.duration <- Time.add b.duration diff; b.netAllocs <- b.netAllocs +. (allocatedWords -. b.startAllocs); - b.netBytes <- b.netBytes +. (allocatedWords *. 8. -. b.startBytes); - b.timerOn <- false - ) + b.netBytes <- b.netBytes +. ((allocatedWords *. 8.) -. b.startBytes); + b.timerOn <- false) let resetTimer b = if b.timerOn then ( - let allocatedWords = mallocs() in + let allocatedWords = mallocs () in b.startAllocs <- allocatedWords; b.netAllocs <- allocatedWords *. 8.; - b.start <- Time.now(); - ); + b.start <- Time.now ()); b.netAllocs <- 0.; b.netBytes <- 0. let runIteration b n = - Gc.full_major(); + Gc.full_major (); b.n <- n; resetTimer b; startTimer b; @@ -167,22 +171,24 @@ end = struct let launch b = (* 150 runs * all the benchmarks means around 1m of benchmark time *) - for n=1 to 150 do + for n = 1 to 150 do runIteration b n done end -module Benchmarks: sig - val run: unit -> unit +module Benchmarks : sig + val run : unit -> unit end = struct type action = Parse | Print - let string_of_action action = match action with - | Parse -> "parser" - | Print -> "printer" + let string_of_action action = + match action with + | Parse -> "parser" + | Print -> "printer" (* TODO: we could at Reason here *) type lang = Ocaml | Rescript - let string_of_lang lang = match lang with + let string_of_lang lang = + match lang with | Ocaml -> "ocaml" | Rescript -> "rescript" @@ -194,33 +200,37 @@ end = struct let parseRescript src filename = let p = Parser.make src filename in let structure = ResParser.parseImplementation p in - assert(p.diagnostics == []); + assert (p.diagnostics == []); structure let benchmark filename lang action = let src = IO.readFile filename in let name = - filename ^ " " ^ (string_of_lang lang) ^ " " ^ (string_of_action action) + filename ^ " " ^ string_of_lang lang ^ " " ^ string_of_action action in - let benchmarkFn = match (lang, action) with - | (Rescript, Parse) -> (fun _ -> - let _ = Sys.opaque_identity (parseRescript src filename) in () - ) - | (Ocaml, Parse) -> (fun _ -> - let _ = Sys.opaque_identity (parseOcaml src filename) in () - ) - | (Rescript, Print) -> - let p = Parser.make src filename in - let ast = ResParser.parseImplementation p in - (fun _ -> - let _ = Sys.opaque_identity ( - let cmtTbl = CommentTable.make () in - let comments = List.rev p.Parser.comments in - let () = CommentTable.walkStructure ast cmtTbl comments in - Doc.toString ~width:80 (Printer.printStructure ast cmtTbl) - ) in () - ) - | _ -> (fun _ -> ()) + let benchmarkFn = + match (lang, action) with + | Rescript, Parse -> + fun _ -> + let _ = Sys.opaque_identity (parseRescript src filename) in + () + | Ocaml, Parse -> + fun _ -> + let _ = Sys.opaque_identity (parseOcaml src filename) in + () + | Rescript, Print -> + let p = Parser.make src filename in + let ast = ResParser.parseImplementation p in + fun _ -> + let _ = + Sys.opaque_identity + (let cmtTbl = CommentTable.make () in + let comments = List.rev p.Parser.comments in + let () = CommentTable.walkStructure ast cmtTbl comments in + Doc.toString ~width:80 (Printer.printStructure ast cmtTbl)) + in + () + | _ -> fun _ -> () in let b = Benchmark.make ~name ~f:benchmarkFn () in Benchmark.launch b; @@ -236,7 +246,7 @@ end = struct benchmark "./benchmarks/data/Napkinscript.res" Rescript Print; benchmark "./benchmarks/data/HeroGraphic.res" Rescript Parse; benchmark "./benchmarks/data/HeroGraphic.ml" Ocaml Parse; - benchmark "./benchmarks/data/HeroGraphic.res" Rescript Print; + benchmark "./benchmarks/data/HeroGraphic.res" Rescript Print end -let () = Benchmarks.run() +let () = Benchmarks.run () diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index 25146acb..b0f060f6 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -4,7 +4,9 @@ open Asttypes open Parsetree open Longident -let rec find_opt p = function [] -> None | x :: l -> if p x then Some x else find_opt p l +let rec find_opt p = function + | [] -> None + | x :: l -> if p x then Some x else find_opt p l let nolabel = Nolabel @@ -12,26 +14,40 @@ let labelled str = Labelled str let optional str = Optional str -let isOptional str = match str with Optional _ -> true | _ -> false +let isOptional str = + match str with + | Optional _ -> true + | _ -> false -let isLabelled str = match str with Labelled _ -> true | _ -> false +let isLabelled str = + match str with + | Labelled _ -> true + | _ -> false -let getLabel str = match str with Optional str | Labelled str -> str | Nolabel -> "" +let getLabel str = + match str with + | Optional str | Labelled str -> str + | Nolabel -> "" let optionIdent = Lident "option" -let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) +let constantString ~loc str = + Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) let safeTypeFromValue valueStr = let valueStr = getLabel valueStr in - match String.sub valueStr 0 1 with "_" -> "T" ^ valueStr | _ -> valueStr + match String.sub valueStr 0 1 with + | "_" -> "T" ^ valueStr + | _ -> valueStr [@@raises Invalid_argument] -let keyType loc = Typ.constr ~loc { loc; txt = optionIdent } [ Typ.constr ~loc { loc; txt = Lident "string" } [] ] +let keyType loc = + Typ.constr ~loc {loc; txt = optionIdent} + [Typ.constr ~loc {loc; txt = Lident "string"} []] type 'a children = ListLiteral of 'a | Exact of 'a -type componentConfig = { propsName : string } +type componentConfig = {propsName: string} (* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) let transformChildrenIfListUpper ~loc ~mapper theList = @@ -39,12 +55,16 @@ let transformChildrenIfListUpper ~loc ~mapper theList = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) match theList with - | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> ( - match accum with - | [ singleElement ] -> Exact singleElement - | accum -> ListLiteral (Exp.array ~loc (List.rev accum)) ) - | { pexp_desc = Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }) } -> - transformChildren_ acc (mapper.expr mapper v :: accum) + | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> ( + match accum with + | [singleElement] -> Exact singleElement + | accum -> ListLiteral (Exp.array ~loc (List.rev accum))) + | { + pexp_desc = + Pexp_construct + ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); + } -> + transformChildren_ acc (mapper.expr mapper v :: accum) | notAList -> Exact (mapper.expr mapper notAList) in transformChildren_ theList [] @@ -54,9 +74,14 @@ let transformChildrenIfList ~loc ~mapper theList = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) match theList with - | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> Exp.array ~loc (List.rev accum) - | { pexp_desc = Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }) } -> - transformChildren_ acc (mapper.expr mapper v :: accum) + | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> + Exp.array ~loc (List.rev accum) + | { + pexp_desc = + Pexp_construct + ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); + } -> + transformChildren_ acc (mapper.expr mapper v :: accum) | notAList -> mapper.expr mapper notAList in transformChildren_ theList [] @@ -65,23 +90,40 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = let rec allButLast_ lst acc = match lst with | [] -> [] - | [ (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }) ] -> acc - | (Nolabel, _) :: _rest -> raise (Invalid_argument "JSX: found non-labelled argument before the last position") + | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> + acc + | (Nolabel, _) :: _rest -> + raise + (Invalid_argument + "JSX: found non-labelled argument before the last position") | arg :: rest -> allButLast_ rest (arg :: acc) [@@raises Invalid_argument] in - let allButLast lst = allButLast_ lst [] |> List.rev [@@raises Invalid_argument] in - match List.partition (fun (label, _) -> label = labelled "children") propsAndChildren with + let allButLast lst = + allButLast_ lst [] |> List.rev + [@@raises Invalid_argument] + in + match + List.partition + (fun (label, _) -> label = labelled "children") + propsAndChildren + with | [], props -> - (* no children provided? Place a placeholder list *) - (Exp.construct ~loc { loc; txt = Lident "[]" } None, if removeLastPositionUnit then allButLast props else props) - | [ (_, childrenExpr) ], props -> (childrenExpr, if removeLastPositionUnit then allButLast props else props) - | _ -> raise (Invalid_argument "JSX: somehow there's more than one `children` label") + (* no children provided? Place a placeholder list *) + ( Exp.construct ~loc {loc; txt = Lident "[]"} None, + if removeLastPositionUnit then allButLast props else props ) + | [(_, childrenExpr)], props -> + (childrenExpr, if removeLastPositionUnit then allButLast props else props) + | _ -> + raise + (Invalid_argument "JSX: somehow there's more than one `children` label") [@@raises Invalid_argument] -let unerasableIgnore loc = ({ loc; txt = "warning" }, PStr [ Str.eval (Exp.constant (Pconst_string ("-16", None))) ]) +let unerasableIgnore loc = + ( {loc; txt = "warning"}, + PStr [Str.eval (Exp.constant (Pconst_string ("-16", None)))] ) -let merlinFocus = ({ loc = Location.none; txt = "merlin.focus" }, PStr []) +let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr []) (* Helper method to look up the [@react.component] attribute *) let hasAttr (loc, _) = loc.txt = "react.component" @@ -90,56 +132,85 @@ let hasAttr (loc, _) = loc.txt = "react.component" let otherAttrsPure (loc, _) = loc.txt <> "react.component" (* Iterate over the attributes and try to find the [@react.component] attribute *) -let hasAttrOnBinding { pvb_attributes } = find_opt hasAttr pvb_attributes <> None +let hasAttrOnBinding {pvb_attributes} = find_opt hasAttr pvb_attributes <> None (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) let rec getFnName binding = match binding with - | { ppat_desc = Ppat_var { txt } } -> txt - | { ppat_desc = Ppat_constraint (pat, _) } -> getFnName pat - | _ -> raise (Invalid_argument "react.component calls cannot be destructured.") + | {ppat_desc = Ppat_var {txt}} -> txt + | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat + | _ -> + raise (Invalid_argument "react.component calls cannot be destructured.") [@@raises Invalid_argument] let makeNewBinding binding expression newName = match binding with - | { pvb_pat = { ppat_desc = Ppat_var ppat_var } as pvb_pat } -> - { - binding with - pvb_pat = { pvb_pat with ppat_desc = Ppat_var { ppat_var with txt = newName } }; - pvb_expr = expression; - pvb_attributes = [ merlinFocus ]; - } - | _ -> raise (Invalid_argument "react.component calls cannot be destructured.") + | {pvb_pat = {ppat_desc = Ppat_var ppat_var} as pvb_pat} -> + { + binding with + pvb_pat = + {pvb_pat with ppat_desc = Ppat_var {ppat_var with txt = newName}}; + pvb_expr = expression; + pvb_attributes = [merlinFocus]; + } + | _ -> + raise (Invalid_argument "react.component calls cannot be destructured.") [@@raises Invalid_argument] (* Lookup the value of `props` otherwise raise Invalid_argument error *) let getPropsNameValue _acc (loc, exp) = match (loc, exp) with - | { txt = Lident "props" }, { pexp_desc = Pexp_ident { txt = Lident str } } -> { propsName = str } - | { txt }, _ -> - raise (Invalid_argument ("react.component only accepts props as an option, given: " ^ Longident.last txt)) + | {txt = Lident "props"}, {pexp_desc = Pexp_ident {txt = Lident str}} -> + {propsName = str} + | {txt}, _ -> + raise + (Invalid_argument + ("react.component only accepts props as an option, given: " + ^ Longident.last txt)) [@@raises Invalid_argument] (* Lookup the `props` record or string as part of [@react.component] and store the name for use when rewriting *) let getPropsAttr payload = - let defaultProps = { propsName = "Props" } in + let defaultProps = {propsName = "Props"} in match payload with - | Some (PStr ({ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_record (recordFields, None) }, _) } :: _rest)) -> - List.fold_left getPropsNameValue defaultProps recordFields - | Some (PStr ({ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_ident { txt = Lident "props" } }, _) } :: _rest)) -> - { propsName = "props" } - | Some (PStr ({ pstr_desc = Pstr_eval (_, _) } :: _rest)) -> - raise (Invalid_argument "react.component accepts a record config with props as an options.") + | Some + (PStr + ({ + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_record (recordFields, None)}, _); + } + :: _rest)) -> + List.fold_left getPropsNameValue defaultProps recordFields + | Some + (PStr + ({ + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_ident {txt = Lident "props"}}, _); + } + :: _rest)) -> + {propsName = "props"} + | Some (PStr ({pstr_desc = Pstr_eval (_, _)} :: _rest)) -> + raise + (Invalid_argument + "react.component accepts a record config with props as an options.") | _ -> defaultProps [@@raises Invalid_argument] (* Plucks the label, loc, and type_ from an AST node *) -let pluckLabelDefaultLocType (label, default, _, _, loc, type_) = (label, default, loc, type_) +let pluckLabelDefaultLocType (label, default, _, _, loc, type_) = + (label, default, loc, type_) (* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) let filenameFromLoc (pstr_loc : Location.t) = - let fileName = match pstr_loc.loc_start.pos_fname with "" -> !Location.input_name | fileName -> fileName in - let fileName = try Filename.chop_extension (Filename.basename fileName) with Invalid_argument _ -> fileName in + let fileName = + match pstr_loc.loc_start.pos_fname with + | "" -> !Location.input_name + | fileName -> fileName + in + let fileName = + try Filename.chop_extension (Filename.basename fileName) + with Invalid_argument _ -> fileName + in let fileName = String.capitalize_ascii fileName in fileName @@ -151,7 +222,8 @@ let makeModuleName fileName nestedModules fnName = | "", nestedModules, "make" -> nestedModules | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules - | fileName, nestedModules, fnName -> fileName :: List.rev (fnName :: nestedModules) + | fileName, nestedModules, fnName -> + fileName :: List.rev (fnName :: nestedModules) in let fullModuleName = String.concat "$" fullModuleName in fullModuleName @@ -166,28 +238,50 @@ let makeModuleName fileName nestedModules fnName = let rec recursivelyMakeNamedArgsForExternal list args = match list with | (label, default, loc, interiorType) :: tl -> - recursivelyMakeNamedArgsForExternal tl - (Typ.arrow ~loc label - ( match (label, interiorType, default) with - (* ~foo=1 *) - | label, None, Some _ -> - { ptyp_desc = Ptyp_var (safeTypeFromValue label); ptyp_loc = loc; ptyp_attributes = [] } - (* ~foo: int=1 *) - | _label, Some type_, Some _ -> type_ - (* ~foo: option(int)=? *) - | label, Some { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]) }, _ - | label, Some { ptyp_desc = Ptyp_constr ({ txt = Ldot (Lident "*predef*", "option") }, [ type_ ]) }, _ - (* ~foo: int=? - note this isnt valid. but we want to get a type error *) - | label, Some type_, _ - when isOptional label -> - type_ - (* ~foo=? *) - | label, None, _ when isOptional label -> - { ptyp_desc = Ptyp_var (safeTypeFromValue label); ptyp_loc = loc; ptyp_attributes = [] } - (* ~foo *) - | label, None, _ -> { ptyp_desc = Ptyp_var (safeTypeFromValue label); ptyp_loc = loc; ptyp_attributes = [] } - | _label, Some type_, _ -> type_ ) - args) + recursivelyMakeNamedArgsForExternal tl + (Typ.arrow ~loc label + (match (label, interiorType, default) with + (* ~foo=1 *) + | label, None, Some _ -> + { + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + (* ~foo: int=1 *) + | _label, Some type_, Some _ -> type_ + (* ~foo: option(int)=? *) + | ( label, + Some {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, [type_])}, + _ ) + | ( label, + Some + { + ptyp_desc = + Ptyp_constr + ({txt = Ldot (Lident "*predef*", "option")}, [type_]); + }, + _ ) + (* ~foo: int=? - note this isnt valid. but we want to get a type error *) + | label, Some type_, _ + when isOptional label -> + type_ + (* ~foo=? *) + | label, None, _ when isOptional label -> + { + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + (* ~foo *) + | label, None, _ -> + { + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + | _label, Some type_, _ -> type_) + args) | [] -> args [@@raises Invalid_argument] @@ -195,36 +289,52 @@ let rec recursivelyMakeNamedArgsForExternal list args = let makePropsValue fnName loc namedArgListWithKeyAndRef propsType = let propsName = fnName ^ "Props" in { - pval_name = { txt = propsName; loc }; + pval_name = {txt = propsName; loc}; pval_type = recursivelyMakeNamedArgsForExternal namedArgListWithKeyAndRef (Typ.arrow nolabel - { ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; loc }, []); ptyp_loc = loc; ptyp_attributes = [] } + { + ptyp_desc = Ptyp_constr ({txt = Lident "unit"; loc}, []); + ptyp_loc = loc; + ptyp_attributes = []; + } propsType); - pval_prim = [ "" ]; - pval_attributes = [ ({ txt = "bs.obj"; loc }, PStr []) ]; + pval_prim = [""]; + pval_attributes = [({txt = "bs.obj"; loc}, PStr [])]; pval_loc = loc; } [@@raises Invalid_argument] (* Build an AST node representing an `external` with the definition of the [@bs.obj] *) let makePropsExternal fnName loc namedArgListWithKeyAndRef propsType = - { pstr_loc = loc; pstr_desc = Pstr_primitive (makePropsValue fnName loc namedArgListWithKeyAndRef propsType) } + { + pstr_loc = loc; + pstr_desc = + Pstr_primitive + (makePropsValue fnName loc namedArgListWithKeyAndRef propsType); + } [@@raises Invalid_argument] (* Build an AST node for the signature of the `external` definition *) let makePropsExternalSig fnName loc namedArgListWithKeyAndRef propsType = - { psig_loc = loc; psig_desc = Psig_value (makePropsValue fnName loc namedArgListWithKeyAndRef propsType) } + { + psig_loc = loc; + psig_desc = + Psig_value (makePropsValue fnName loc namedArgListWithKeyAndRef propsType); + } [@@raises Invalid_argument] (* Build an AST node for the props name when converted to an object inside the function signature *) -let makePropsName ~loc name = { ppat_desc = Ppat_var { txt = name; loc }; ppat_loc = loc; ppat_attributes = [] } +let makePropsName ~loc name = + {ppat_desc = Ppat_var {txt = name; loc}; ppat_loc = loc; ppat_attributes = []} -let makeObjectField loc (str, attrs, type_) = Otag ({ loc; txt = str }, attrs, type_) +let makeObjectField loc (str, attrs, type_) = + Otag ({loc; txt = str}, attrs, type_) (* Build an AST node representing a "closed" object representing a component's props *) let makePropsType ~loc namedTypeList = - Typ.mk ~loc (Ptyp_object (List.map (makeObjectField loc) namedTypeList, Closed)) + Typ.mk ~loc + (Ptyp_object (List.map (makeObjectField loc) namedTypeList, Closed)) (* Builds an AST node for the entire `external` definition of props *) let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList = @@ -249,23 +359,30 @@ let jsxMapper () = let jsxVersion = ref None in let transformUppercaseCall3 modulePath mapper loc attrs _ callArguments = - let children, argsWithLabels = extractChildren ~loc ~removeLastPositionUnit:true callArguments in + let children, argsWithLabels = + extractChildren ~loc ~removeLastPositionUnit:true callArguments + in let argsForMake = argsWithLabels in let childrenExpr = transformChildrenIfListUpper ~loc ~mapper children in let recursivelyTransformedArgsForMake = - argsForMake |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) + argsForMake + |> List.map (fun (label, expression) -> + (label, mapper.expr mapper expression)) in let childrenArg = ref None in let args = recursivelyTransformedArgsForMake - @ ( match childrenExpr with - | Exact children -> [ (labelled "children", children) ] - | ListLiteral { pexp_desc = Pexp_array list } when list = [] -> [] + @ (match childrenExpr with + | Exact children -> [(labelled "children", children)] + | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] | ListLiteral expression -> - (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; - [ (labelled "children", Exp.ident ~loc { loc; txt = Ldot (Lident "React", "null") }) ] ) - @ [ (nolabel, Exp.construct ~loc { loc; txt = Lident "()" } None) ] + (* this is a hack to support react components that introspect into their children *) + childrenArg := Some expression; + [ + ( labelled "children", + Exp.ident ~loc {loc; txt = Ldot (Lident "React", "null")} ); + ]) + @ [(nolabel, Exp.construct ~loc {loc; txt = Lident "()"} None)] in let isCap str = let first = String.sub str 0 1 [@@raises Invalid_argument] in @@ -276,27 +393,38 @@ let jsxMapper () = let ident = match modulePath with | Lident _ -> Ldot (modulePath, "make") - | Ldot (_modulePath, value) as fullPath when isCap value -> Ldot (fullPath, "make") + | Ldot (_modulePath, value) as fullPath when isCap value -> + Ldot (fullPath, "make") | modulePath -> modulePath in let propsIdent = match ident with | Lident path -> Lident (path ^ "Props") | Ldot (ident, path) -> Ldot (ident, path ^ "Props") - | _ -> raise (Invalid_argument "JSX name can't be the result of function applications") + | _ -> + raise + (Invalid_argument + "JSX name can't be the result of function applications") + in + let props = + Exp.apply ~attrs ~loc (Exp.ident ~loc {loc; txt = propsIdent}) args in - let props = Exp.apply ~attrs ~loc (Exp.ident ~loc { loc; txt = propsIdent }) args in (* handle key, ref, children *) (* React.createElement(Component.make, props, ...children) *) match !childrenArg with | None -> - Exp.apply ~loc ~attrs - (Exp.ident ~loc { loc; txt = Ldot (Lident "React", "createElement") }) - [ (nolabel, Exp.ident ~loc { txt = ident; loc }); (nolabel, props) ] + Exp.apply ~loc ~attrs + (Exp.ident ~loc {loc; txt = Ldot (Lident "React", "createElement")}) + [(nolabel, Exp.ident ~loc {txt = ident; loc}); (nolabel, props)] | Some children -> - Exp.apply ~loc ~attrs - (Exp.ident ~loc { loc; txt = Ldot (Lident "React", "createElementVariadic") }) - [ (nolabel, Exp.ident ~loc { txt = ident; loc }); (nolabel, props); (nolabel, children) ] + Exp.apply ~loc ~attrs + (Exp.ident ~loc + {loc; txt = Ldot (Lident "React", "createElementVariadic")}) + [ + (nolabel, Exp.ident ~loc {txt = ident; loc}); + (nolabel, props); + (nolabel, children); + ] [@@raises Invalid_argument] in @@ -309,39 +437,49 @@ let jsxMapper () = (* [@JSX] div(~children=[a]), coming from
a
*) | { pexp_desc = - ( Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple _ }) - | Pexp_construct ({ txt = Lident "[]" }, None) ); + ( Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _}) + | Pexp_construct ({txt = Lident "[]"}, None) ); } -> - "createDOMElementVariadic" + "createDOMElementVariadic" (* [@JSX] div(~children= value), coming from
...(value)
*) | _ -> - raise - (Invalid_argument - "A spread as a DOM element's children don't make sense written together. You can simply remove the \ - spread.") + raise + (Invalid_argument + "A spread as a DOM element's children don't make sense written \ + together. You can simply remove the spread.") in let args = match nonChildrenProps with - | [ _justTheUnitArgumentAtEnd ] -> - [ (* "div" *) (nolabel, componentNameExpr); (* [|moreCreateElementCallsHere|] *) (nolabel, childrenExpr) ] + | [_justTheUnitArgumentAtEnd] -> + [ + (* "div" *) + (nolabel, componentNameExpr); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] | nonEmptyProps -> - let propsCall = - Exp.apply ~loc - (Exp.ident ~loc { loc; txt = Ldot (Lident "ReactDOMRe", "domProps") }) - (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression))) - in - [ - (* "div" *) - (nolabel, componentNameExpr); - (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) - (labelled "props", propsCall); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] + let propsCall = + Exp.apply ~loc + (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "domProps")}) + (nonEmptyProps + |> List.map (fun (label, expression) -> + (label, mapper.expr mapper expression))) + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsCall); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] in - Exp.apply ~loc (* throw away the [@JSX] attribute and keep the others, if any *) ~attrs + Exp.apply + ~loc (* throw away the [@JSX] attribute and keep the others, if any *) + ~attrs (* ReactDOMRe.createElement *) - (Exp.ident ~loc { loc; txt = Ldot (Lident "ReactDOMRe", createElementCall) }) + (Exp.ident ~loc + {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) args [@@raises Invalid_argument] in @@ -351,90 +489,131 @@ let jsxMapper () = match expr.pexp_desc with (* TODO: make this show up with a loc. *) | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> - raise - (Invalid_argument - "Key cannot be accessed inside of a component. Don't worry - you can always key a component from its \ - parent!") + raise + (Invalid_argument + "Key cannot be accessed inside of a component. Don't worry - you \ + can always key a component from its parent!") | Pexp_fun (Labelled "ref", _, _, _) | Pexp_fun (Optional "ref", _, _, _) -> - raise (Invalid_argument "Ref cannot be passed as a normal prop. Please use `forwardRef` API instead.") - | Pexp_fun (arg, default, pattern, expression) when isOptional arg || isLabelled arg -> - let () = - match (isOptional arg, pattern, default) with - | true, { ppat_desc = Ppat_constraint (_, { ptyp_desc }) }, None -> ( + raise + (Invalid_argument + "Ref cannot be passed as a normal prop. Please use `forwardRef` API \ + instead.") + | Pexp_fun (arg, default, pattern, expression) + when isOptional arg || isLabelled arg -> + let () = + match (isOptional arg, pattern, default) with + | true, {ppat_desc = Ppat_constraint (_, {ptyp_desc})}, None -> ( + match ptyp_desc with + | Ptyp_constr ({txt = Lident "option"}, [_]) -> () + | _ -> + let currentType = match ptyp_desc with - | Ptyp_constr ({ txt = Lident "option" }, [ _ ]) -> () - | _ -> - let currentType = - match ptyp_desc with - | Ptyp_constr ({ txt }, []) -> String.concat "." (Longident.flatten txt) - | Ptyp_constr ({ txt }, _innerTypeArgs) -> String.concat "." (Longident.flatten txt) ^ "(...)" - | _ -> "..." - in - Location.prerr_warning pattern.ppat_loc - (Preprocessor - (Printf.sprintf - "React: optional argument annotations must have explicit `option`. Did you mean \ - `option(%s)=?`?" - currentType)) ) - | _ -> () - in - let alias = - match pattern with - | { ppat_desc = Ppat_alias (_, { txt }) | Ppat_var { txt } } -> txt - | { ppat_desc = Ppat_any } -> "_" - | _ -> getLabel arg - in - let type_ = match pattern with { ppat_desc = Ppat_constraint (_, type_) } -> Some type_ | _ -> None in + | Ptyp_constr ({txt}, []) -> + String.concat "." (Longident.flatten txt) + | Ptyp_constr ({txt}, _innerTypeArgs) -> + String.concat "." (Longident.flatten txt) ^ "(...)" + | _ -> "..." + in + Location.prerr_warning pattern.ppat_loc + (Preprocessor + (Printf.sprintf + "React: optional argument annotations must have explicit \ + `option`. Did you mean `option(%s)=?`?" + currentType))) + | _ -> () + in + let alias = + match pattern with + | {ppat_desc = Ppat_alias (_, {txt}) | Ppat_var {txt}} -> txt + | {ppat_desc = Ppat_any} -> "_" + | _ -> getLabel arg + in + let type_ = + match pattern with + | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_ + | _ -> None + in - recursivelyTransformNamedArgsForMake mapper expression - ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) newtypes - | Pexp_fun (Nolabel, _, { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, _expression) -> - (args, newtypes, None) + recursivelyTransformNamedArgsForMake mapper expression + ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) + newtypes | Pexp_fun ( Nolabel, _, - { ppat_desc = Ppat_var { txt } | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) }, + {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}, _expression ) -> - (args, newtypes, Some txt) + (args, newtypes, None) + | Pexp_fun + ( Nolabel, + _, + { + ppat_desc = + Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _); + }, + _expression ) -> + (args, newtypes, Some txt) | Pexp_fun (Nolabel, _, pattern, _expression) -> - Location.raise_errorf ~loc:pattern.ppat_loc - "React: react.component refs only support plain arguments and type annotations." + Location.raise_errorf ~loc:pattern.ppat_loc + "React: react.component refs only support plain arguments and type \ + annotations." | Pexp_newtype (label, expression) -> - recursivelyTransformNamedArgsForMake mapper expression args (label :: newtypes) + recursivelyTransformNamedArgsForMake mapper expression args + (label :: newtypes) | Pexp_constraint (expression, _typ) -> - recursivelyTransformNamedArgsForMake mapper expression args newtypes + recursivelyTransformNamedArgsForMake mapper expression args newtypes | _ -> (args, newtypes, None) [@@raises Invalid_argument] in let argToType types (name, default, _noLabelName, _alias, loc, type_) = match (type_, name, default) with - | Some { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]) }, name, _ when isOptional name -> - ( getLabel name, - [], - { type_ with ptyp_desc = Ptyp_constr ({ loc = type_.ptyp_loc; txt = optionIdent }, [ type_ ]) } ) - :: types + | Some {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, [type_])}, name, _ + when isOptional name -> + ( getLabel name, + [], + { + type_ with + ptyp_desc = + Ptyp_constr ({loc = type_.ptyp_loc; txt = optionIdent}, [type_]); + } ) + :: types | Some type_, name, Some _default -> - ( getLabel name, - [], - { ptyp_desc = Ptyp_constr ({ loc; txt = optionIdent }, [ type_ ]); ptyp_loc = loc; ptyp_attributes = [] } ) - :: types + ( getLabel name, + [], + { + ptyp_desc = Ptyp_constr ({loc; txt = optionIdent}, [type_]); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types | Some type_, name, _ -> (getLabel name, [], type_) :: types | None, name, _ when isOptional name -> - ( getLabel name, - [], - { - ptyp_desc = - Ptyp_constr - ( { loc; txt = optionIdent }, - [ { ptyp_desc = Ptyp_var (safeTypeFromValue name); ptyp_loc = loc; ptyp_attributes = [] } ] ); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types + ( getLabel name, + [], + { + ptyp_desc = + Ptyp_constr + ( {loc; txt = optionIdent}, + [ + { + ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_loc = loc; + ptyp_attributes = []; + }; + ] ); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types | None, name, _ when isLabelled name -> - (getLabel name, [], { ptyp_desc = Ptyp_var (safeTypeFromValue name); ptyp_loc = loc; ptyp_attributes = [] }) - :: types + ( getLabel name, + [], + { + ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types | _ -> types [@@raises Invalid_argument] in @@ -442,7 +621,9 @@ let jsxMapper () = let argToConcreteType types (name, loc, type_) = match name with | name when isLabelled name -> (getLabel name, [], type_) :: types - | name when isOptional name -> (getLabel name, [], Typ.constr ~loc { loc; txt = optionIdent } [ type_ ]) :: types + | name when isOptional name -> + (getLabel name, [], Typ.constr ~loc {loc; txt = optionIdent} [type_]) + :: types | _ -> types in @@ -452,300 +633,438 @@ let jsxMapper () = (* external *) | { pstr_loc; - pstr_desc = Pstr_primitive ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as value_description); + pstr_desc = + Pstr_primitive + ({pval_name = {txt = fnName}; pval_attributes; pval_type} as + value_description); } as pstr -> ( - match List.filter hasAttr pval_attributes with - | [] -> structure :: returnStructures - | [ _ ] -> - let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) when isLabelled name || isOptional name - -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) when isLabelled name || isOptional name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let pluckLabelAndLoc (label, loc, type_) = (label, None (* default *), loc, Some type_) in - let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in - let externalPropsDecl = - makePropsExternal fnName pstr_loc - ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) :: List.map pluckLabelAndLoc propTypes) - retPropsType + match List.filter hasAttr pval_attributes with + | [] -> structure :: returnStructures + | [_] -> + let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) + when isLabelled name || isOptional name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isLabelled name || isOptional name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = + (label, None (* default *), loc, Some type_) + in + let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in + let externalPropsDecl = + makePropsExternal fnName pstr_loc + ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) + :: List.map pluckLabelAndLoc propTypes) + retPropsType + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr + ( {loc = pstr_loc; txt = Ldot (Lident "React", "componentLike")}, + [retPropsType; innerType] ) + in + let newStructure = + { + pstr with + pstr_desc = + Pstr_primitive + { + value_description with + pval_type = {pval_type with ptyp_desc = newExternalType}; + pval_attributes = List.filter otherAttrsPure pval_attributes; + }; + } + in + externalPropsDecl :: newStructure :: returnStructures + | _ -> + raise + (Invalid_argument + "Only one react.component call can exist on a component at one \ + time")) + (* let component = ... *) + | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> + let fileName = filenameFromLoc pstr_loc in + let emptyLoc = Location.in_file fileName in + let mapBinding binding = + if hasAttrOnBinding binding then + let bindingLoc = binding.pvb_loc in + let bindingPatLoc = binding.pvb_pat.ppat_loc in + let binding = + { + binding with + pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc}; + pvb_loc = emptyLoc; + } + in + let fnName = getFnName binding.pvb_pat in + let internalFnName = fnName ^ "$Internal" in + let fullModuleName = makeModuleName fileName !nestedModules fnName in + let modifiedBindingOld binding = + let expression = binding.pvb_expr in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... *) + | {pexp_desc = Pexp_fun _} | {pexp_desc = Pexp_newtype _} -> + expression + (* let make = {let foo = bar in (~prop) => ...} *) + | {pexp_desc = Pexp_let (_recursive, _vbs, returnExpression)} -> + (* here's where we spelunk! *) + spelunkForFunExpression returnExpression + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = + Pexp_apply + (_wrapperExpression, [(Nolabel, innerFunctionExpression)]); + } -> + spelunkForFunExpression innerFunctionExpression + | { + pexp_desc = + Pexp_sequence (_wrapperExpression, innerFunctionExpression); + } -> + spelunkForFunExpression innerFunctionExpression + | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} -> + spelunkForFunExpression innerFunctionExpression + | _ -> + raise + (Invalid_argument + "react.component calls can only be on function \ + definitions or component wrappers (forwardRef, memo).") + [@@raises Invalid_argument] in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr ({ loc = pstr_loc; txt = Ldot (Lident "React", "componentLike") }, [ retPropsType; innerType ]) + spelunkForFunExpression expression + in + let modifiedBinding binding = + let hasApplication = ref false in + let wrapExpressionWithBinding expressionFn expression = + Vb.mk ~loc:bindingLoc + ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) + (Pat.var ~loc:bindingPatLoc {loc = bindingPatLoc; txt = fnName}) + (expressionFn expression) in - let newStructure = + let expression = binding.pvb_expr in + let unerasableIgnoreExp exp = { - pstr with - pstr_desc = - Pstr_primitive - { - value_description with - pval_type = { pval_type with ptyp_desc = newExternalType }; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; + exp with + pexp_attributes = + unerasableIgnore emptyLoc :: exp.pexp_attributes; } in - externalPropsDecl :: newStructure :: returnStructures - | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time") ) - (* let component = ... *) - | { pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings) } -> - let fileName = filenameFromLoc pstr_loc in - let emptyLoc = Location.in_file fileName in - let mapBinding binding = - if hasAttrOnBinding binding then - let bindingLoc = binding.pvb_loc in - let bindingPatLoc = binding.pvb_pat.ppat_loc in - let binding = { binding with pvb_pat = { binding.pvb_pat with ppat_loc = emptyLoc }; pvb_loc = emptyLoc } in - let fnName = getFnName binding.pvb_pat in - let internalFnName = fnName ^ "$Internal" in - let fullModuleName = makeModuleName fileName !nestedModules fnName in - let modifiedBindingOld binding = - let expression = binding.pvb_expr in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... *) - | { pexp_desc = Pexp_fun _ } - | { pexp_desc = Pexp_newtype _ } -> expression - (* let make = {let foo = bar in (~prop) => ...} *) - | { pexp_desc = Pexp_let (_recursive, _vbs, returnExpression) } -> - (* here's where we spelunk! *) - spelunkForFunExpression returnExpression - (* let make = React.forwardRef((~prop) => ...) *) - | { pexp_desc = Pexp_apply (_wrapperExpression, [ (Nolabel, innerFunctionExpression) ]) } -> - spelunkForFunExpression innerFunctionExpression - | { pexp_desc = Pexp_sequence (_wrapperExpression, innerFunctionExpression) } -> - spelunkForFunExpression innerFunctionExpression - | { pexp_desc = Pexp_constraint (innerFunctionExpression, _typ) } -> - spelunkForFunExpression innerFunctionExpression - | _ -> - raise - (Invalid_argument - "react.component calls can only be on function definitions or component wrappers (forwardRef, \ - memo).") - [@@raises Invalid_argument] - in - spelunkForFunExpression expression - in - let modifiedBinding binding = - let hasApplication = ref false in - let wrapExpressionWithBinding expressionFn expression = - Vb.mk ~loc:bindingLoc - ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) - (Pat.var ~loc:bindingPatLoc { loc = bindingPatLoc; txt = fnName }) - (expressionFn expression) - in - let expression = binding.pvb_expr in - let unerasableIgnoreExp exp = - { exp with pexp_attributes = unerasableIgnore emptyLoc :: exp.pexp_attributes } - in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... with no final unit *) - | { - pexp_desc = - Pexp_fun - ( ((Labelled _ | Optional _) as label), - default, - pattern, - ({ pexp_desc = Pexp_fun _ } as internalExpression) ); - } -> - let wrap, hasUnit, exp = spelunkForFunExpression internalExpression in - ( wrap, - hasUnit, - unerasableIgnoreExp { expression with pexp_desc = Pexp_fun (label, default, pattern, exp) } ) - (* let make = (()) => ... *) - (* let make = (_) => ... *) - | { - pexp_desc = - Pexp_fun - ( Nolabel, - _default, - { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, - _internalExpression ); - } -> - ((fun a -> a), true, expression) - (* let make = (~prop) => ... *) - | { pexp_desc = Pexp_fun ((Labelled _ | Optional _), _default, _pattern, _internalExpression) } -> - ((fun a -> a), false, unerasableIgnoreExp expression) - (* let make = (prop) => ... *) - | { pexp_desc = Pexp_fun (_nolabel, _default, pattern, _internalExpression) } -> - if hasApplication.contents then ((fun a -> a), false, unerasableIgnoreExp expression) - else - Location.raise_errorf ~loc:pattern.ppat_loc - "React: props need to be labelled arguments.\n\ - \ If you are working with refs be sure to wrap with React.forwardRef.\n\ - \ If your component doesn't have any props use () or _ instead of a name." - (* let make = {let foo = bar in (~prop) => ...} *) - | { pexp_desc = Pexp_let (recursive, vbs, internalExpression) } -> - (* here's where we spelunk! *) - let wrap, hasUnit, exp = spelunkForFunExpression internalExpression in - (wrap, hasUnit, { expression with pexp_desc = Pexp_let (recursive, vbs, exp) }) - (* let make = React.forwardRef((~prop) => ...) *) - | { pexp_desc = Pexp_apply (wrapperExpression, [ (Nolabel, internalExpression) ]) } -> - let () = hasApplication := true in - let _, hasUnit, exp = spelunkForFunExpression internalExpression in - ((fun exp -> Exp.apply wrapperExpression [ (nolabel, exp) ]), hasUnit, exp) - | { pexp_desc = Pexp_sequence (wrapperExpression, internalExpression) } -> - let wrap, hasUnit, exp = spelunkForFunExpression internalExpression in - (wrap, hasUnit, { expression with pexp_desc = Pexp_sequence (wrapperExpression, exp) }) - | e -> ((fun a -> a), false, e) - in - let wrapExpression, hasUnit, expression = spelunkForFunExpression expression in - (wrapExpressionWithBinding wrapExpression, hasUnit, expression) - in - let bindingWrapper, hasUnit, expression = modifiedBinding binding in - let reactComponentAttribute = - try Some (List.find hasAttr binding.pvb_attributes) with Not_found -> None - in - let _attr_loc, payload = - match reactComponentAttribute with - | Some (loc, payload) -> (loc.loc, Some payload) - | None -> (emptyLoc, None) - in - let props = getPropsAttr payload in - (* do stuff here! *) - let namedArgList, newtypes, forwardRef = - recursivelyTransformNamedArgsForMake mapper (modifiedBindingOld binding) [] [] - in - let namedArgListWithKeyAndRef = - (optional "key", None, Pat.var { txt = "key"; loc = emptyLoc }, "key", emptyLoc, Some (keyType emptyLoc)) - :: namedArgList - in - let namedArgListWithKeyAndRef = - match forwardRef with - | Some _ -> - (optional "ref", None, Pat.var { txt = "key"; loc = emptyLoc }, "ref", emptyLoc, None) - :: namedArgListWithKeyAndRef - | None -> namedArgListWithKeyAndRef - in - let namedArgListWithKeyAndRefForNew = - match forwardRef with - | Some txt -> namedArgList @ [ (nolabel, None, Pat.var { txt; loc = emptyLoc }, txt, emptyLoc, None) ] - | None -> namedArgList - in - let pluckArg (label, _, _, alias, loc, _) = - let labelString = - match label with label when isOptional label || isLabelled label -> getLabel label | _ -> "" - in - ( label, - match labelString with - | "" -> Exp.ident ~loc { txt = Lident alias; loc } - | labelString -> - Exp.apply ~loc - (Exp.ident ~loc { txt = Lident "##"; loc }) - [ - (nolabel, Exp.ident ~loc { txt = Lident props.propsName; loc }); - (nolabel, Exp.ident ~loc { txt = Lident labelString; loc }); - ] ) - in - let namedTypeList = List.fold_left argToType [] namedArgList in - let loc = emptyLoc in - let externalArgs = (* translate newtypes to type variables *) - List.fold_left - (fun args newtype -> - List.map (fun (a, b, c, d, e, maybeTyp) -> - match maybeTyp with - | Some typ -> (a, b, c, d, e, Some (newtypeToVar newtype.txt typ)) - | None -> (a, b, c, d, e, None)) - args) - namedArgListWithKeyAndRef - newtypes - in - let externalTypes = (* translate newtypes to type variables *) - List.fold_left - (fun args newtype -> - List.map (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ)) args) - namedTypeList - newtypes - in - let externalDecl = makeExternalDecl fnName loc externalArgs externalTypes in - let innerExpressionArgs = - List.map pluckArg namedArgListWithKeyAndRefForNew - @ if hasUnit then [ (Nolabel, Exp.construct { loc; txt = Lident "()" } None) ] else [] - in - let innerExpression = - Exp.apply - (Exp.ident - { loc; txt = Lident (match recFlag with Recursive -> internalFnName | Nonrecursive -> fnName) }) - innerExpressionArgs - in - let innerExpressionWithRef = - match forwardRef with - | Some txt -> + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... with no final unit *) + | { + pexp_desc = + Pexp_fun + ( ((Labelled _ | Optional _) as label), + default, + pattern, + ({pexp_desc = Pexp_fun _} as internalExpression) ); + } -> + let wrap, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + unerasableIgnoreExp + { + expression with + pexp_desc = Pexp_fun (label, default, pattern, exp); + } ) + (* let make = (()) => ... *) + (* let make = (_) => ... *) + | { + pexp_desc = + Pexp_fun + ( Nolabel, + _default, + { + ppat_desc = + Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; + }, + _internalExpression ); + } -> + ((fun a -> a), true, expression) + (* let make = (~prop) => ... *) + | { + pexp_desc = + Pexp_fun + ( (Labelled _ | Optional _), + _default, + _pattern, + _internalExpression ); + } -> + ((fun a -> a), false, unerasableIgnoreExp expression) + (* let make = (prop) => ... *) + | { + pexp_desc = + Pexp_fun (_nolabel, _default, pattern, _internalExpression); + } -> + if hasApplication.contents then + ((fun a -> a), false, unerasableIgnoreExp expression) + else + Location.raise_errorf ~loc:pattern.ppat_loc + "React: props need to be labelled arguments.\n\ + \ If you are working with refs be sure to wrap with \ + React.forwardRef.\n\ + \ If your component doesn't have any props use () or _ \ + instead of a name." + (* let make = {let foo = bar in (~prop) => ...} *) + | {pexp_desc = Pexp_let (recursive, vbs, internalExpression)} -> + (* here's where we spelunk! *) + let wrap, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + {expression with pexp_desc = Pexp_let (recursive, vbs, exp)} + ) + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = + Pexp_apply (wrapperExpression, [(Nolabel, internalExpression)]); + } -> + let () = hasApplication := true in + let _, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), + hasUnit, + exp ) + | { + pexp_desc = Pexp_sequence (wrapperExpression, internalExpression); + } -> + let wrap, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, { - innerExpression with - pexp_desc = - Pexp_fun - ( nolabel, - None, - { ppat_desc = Ppat_var { txt; loc = emptyLoc }; ppat_loc = emptyLoc; ppat_attributes = [] }, - innerExpression ); - } - | None -> innerExpression - in - let fullExpression = - Exp.fun_ nolabel None - { - ppat_desc = - Ppat_constraint - (makePropsName ~loc:emptyLoc props.propsName, makePropsType ~loc:emptyLoc externalTypes); - ppat_loc = emptyLoc; - ppat_attributes = []; - } - innerExpressionWithRef + expression with + pexp_desc = Pexp_sequence (wrapperExpression, exp); + } ) + | e -> ((fun a -> a), false, e) in - let fullExpression = - match fullModuleName with - | "" -> fullExpression - | txt -> - Exp.let_ Nonrecursive - [ Vb.mk ~loc:emptyLoc (Pat.var ~loc:emptyLoc { loc = emptyLoc; txt }) fullExpression ] - (Exp.ident ~loc:emptyLoc { loc = emptyLoc; txt = Lident txt }) + let wrapExpression, hasUnit, expression = + spelunkForFunExpression expression in - let bindings, newBinding = - match recFlag with - | Recursive -> - ( [ - bindingWrapper - (Exp.let_ ~loc:emptyLoc Recursive - [ - makeNewBinding binding expression internalFnName; - Vb.mk (Pat.var { loc = emptyLoc; txt = fnName }) fullExpression; - ] - (Exp.ident { loc = emptyLoc; txt = Lident fnName })); - ], - None ) - | Nonrecursive -> - ([ { binding with pvb_expr = expression; pvb_attributes = [] } ], Some (bindingWrapper fullExpression)) + (wrapExpressionWithBinding wrapExpression, hasUnit, expression) + in + let bindingWrapper, hasUnit, expression = modifiedBinding binding in + let reactComponentAttribute = + try Some (List.find hasAttr binding.pvb_attributes) + with Not_found -> None + in + let _attr_loc, payload = + match reactComponentAttribute with + | Some (loc, payload) -> (loc.loc, Some payload) + | None -> (emptyLoc, None) + in + let props = getPropsAttr payload in + (* do stuff here! *) + let namedArgList, newtypes, forwardRef = + recursivelyTransformNamedArgsForMake mapper + (modifiedBindingOld binding) + [] [] + in + let namedArgListWithKeyAndRef = + ( optional "key", + None, + Pat.var {txt = "key"; loc = emptyLoc}, + "key", + emptyLoc, + Some (keyType emptyLoc) ) + :: namedArgList + in + let namedArgListWithKeyAndRef = + match forwardRef with + | Some _ -> + ( optional "ref", + None, + Pat.var {txt = "key"; loc = emptyLoc}, + "ref", + emptyLoc, + None ) + :: namedArgListWithKeyAndRef + | None -> namedArgListWithKeyAndRef + in + let namedArgListWithKeyAndRefForNew = + match forwardRef with + | Some txt -> + namedArgList + @ [ + ( nolabel, + None, + Pat.var {txt; loc = emptyLoc}, + txt, + emptyLoc, + None ); + ] + | None -> namedArgList + in + let pluckArg (label, _, _, alias, loc, _) = + let labelString = + match label with + | label when isOptional label || isLabelled label -> + getLabel label + | _ -> "" in - (Some externalDecl, bindings, newBinding) - else (None, [ binding ], None) - [@@raises Invalid_argument] - in - let structuresAndBinding = List.map mapBinding valueBindings in - let otherStructures (extern, binding, newBinding) (externs, bindings, newBindings) = - let externs = match extern with Some extern -> extern :: externs | None -> externs in - let newBindings = - match newBinding with Some newBinding -> newBinding :: newBindings | None -> newBindings + ( label, + match labelString with + | "" -> Exp.ident ~loc {txt = Lident alias; loc} + | labelString -> + Exp.apply ~loc + (Exp.ident ~loc {txt = Lident "##"; loc}) + [ + (nolabel, Exp.ident ~loc {txt = Lident props.propsName; loc}); + (nolabel, Exp.ident ~loc {txt = Lident labelString; loc}); + ] ) in - (externs, binding @ bindings, newBindings) + let namedTypeList = List.fold_left argToType [] namedArgList in + let loc = emptyLoc in + let externalArgs = + (* translate newtypes to type variables *) + List.fold_left + (fun args newtype -> + List.map + (fun (a, b, c, d, e, maybeTyp) -> + match maybeTyp with + | Some typ -> + (a, b, c, d, e, Some (newtypeToVar newtype.txt typ)) + | None -> (a, b, c, d, e, None)) + args) + namedArgListWithKeyAndRef newtypes + in + let externalTypes = + (* translate newtypes to type variables *) + List.fold_left + (fun args newtype -> + List.map + (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ)) + args) + namedTypeList newtypes + in + let externalDecl = + makeExternalDecl fnName loc externalArgs externalTypes + in + let innerExpressionArgs = + List.map pluckArg namedArgListWithKeyAndRefForNew + @ + if hasUnit then + [(Nolabel, Exp.construct {loc; txt = Lident "()"} None)] + else [] + in + let innerExpression = + Exp.apply + (Exp.ident + { + loc; + txt = + Lident + (match recFlag with + | Recursive -> internalFnName + | Nonrecursive -> fnName); + }) + innerExpressionArgs + in + let innerExpressionWithRef = + match forwardRef with + | Some txt -> + { + innerExpression with + pexp_desc = + Pexp_fun + ( nolabel, + None, + { + ppat_desc = Ppat_var {txt; loc = emptyLoc}; + ppat_loc = emptyLoc; + ppat_attributes = []; + }, + innerExpression ); + } + | None -> innerExpression + in + let fullExpression = + Exp.fun_ nolabel None + { + ppat_desc = + Ppat_constraint + ( makePropsName ~loc:emptyLoc props.propsName, + makePropsType ~loc:emptyLoc externalTypes ); + ppat_loc = emptyLoc; + ppat_attributes = []; + } + innerExpressionWithRef + in + let fullExpression = + match fullModuleName with + | "" -> fullExpression + | txt -> + Exp.let_ Nonrecursive + [ + Vb.mk ~loc:emptyLoc + (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt}) + fullExpression; + ] + (Exp.ident ~loc:emptyLoc {loc = emptyLoc; txt = Lident txt}) + in + let bindings, newBinding = + match recFlag with + | Recursive -> + ( [ + bindingWrapper + (Exp.let_ ~loc:emptyLoc Recursive + [ + makeNewBinding binding expression internalFnName; + Vb.mk + (Pat.var {loc = emptyLoc; txt = fnName}) + fullExpression; + ] + (Exp.ident {loc = emptyLoc; txt = Lident fnName})); + ], + None ) + | Nonrecursive -> + ( [{binding with pvb_expr = expression; pvb_attributes = []}], + Some (bindingWrapper fullExpression) ) + in + (Some externalDecl, bindings, newBinding) + else (None, [binding], None) + [@@raises Invalid_argument] + in + let structuresAndBinding = List.map mapBinding valueBindings in + let otherStructures (extern, binding, newBinding) + (externs, bindings, newBindings) = + let externs = + match extern with + | Some extern -> extern :: externs + | None -> externs + in + let newBindings = + match newBinding with + | Some newBinding -> newBinding :: newBindings + | None -> newBindings in - let externs, bindings, newBindings = List.fold_right otherStructures structuresAndBinding ([], [], []) in - externs - @ [ { pstr_loc; pstr_desc = Pstr_value (recFlag, bindings) } ] - @ ( match newBindings with - | [] -> [] - | newBindings -> [ { pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings) } ] ) - @ returnStructures + (externs, binding @ bindings, newBindings) + in + let externs, bindings, newBindings = + List.fold_right otherStructures structuresAndBinding ([], [], []) + in + externs + @ [{pstr_loc; pstr_desc = Pstr_value (recFlag, bindings)}] + @ (match newBindings with + | [] -> [] + | newBindings -> + [{pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings)}]) + @ returnStructures | structure -> structure :: returnStructures [@@raises Invalid_argument] in @@ -757,48 +1076,63 @@ let jsxMapper () = let transformComponentSignature _mapper signature returnSignatures = match signature with - | { psig_loc; psig_desc = Psig_value ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as psig_desc) } - as psig -> ( - match List.filter hasAttr pval_attributes with - | [] -> signature :: returnSignatures - | [ _ ] -> - let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) when isOptional name || isLabelled name - -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) when isOptional name || isLabelled name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let pluckLabelAndLoc (label, loc, type_) = (label, None, loc, Some type_) in - let retPropsType = makePropsType ~loc:psig_loc namedTypeList in - let externalPropsDecl = - makePropsExternalSig fnName psig_loc - ((optional "key", None, psig_loc, Some (keyType psig_loc)) :: List.map pluckLabelAndLoc propTypes) - retPropsType - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr ({ loc = psig_loc; txt = Ldot (Lident "React", "componentLike") }, [ retPropsType; innerType ]) - in - let newStructure = - { - psig with - psig_desc = - Psig_value - { - psig_desc with - pval_type = { pval_type with ptyp_desc = newExternalType }; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - externalPropsDecl :: newStructure :: returnSignatures - | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time") ) + | { + psig_loc; + psig_desc = + Psig_value + ({pval_name = {txt = fnName}; pval_attributes; pval_type} as + psig_desc); + } as psig -> ( + match List.filter hasAttr pval_attributes with + | [] -> signature :: returnSignatures + | [_] -> + let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) + when isOptional name || isLabelled name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = + (label, None, loc, Some type_) + in + let retPropsType = makePropsType ~loc:psig_loc namedTypeList in + let externalPropsDecl = + makePropsExternalSig fnName psig_loc + ((optional "key", None, psig_loc, Some (keyType psig_loc)) + :: List.map pluckLabelAndLoc propTypes) + retPropsType + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr + ( {loc = psig_loc; txt = Ldot (Lident "React", "componentLike")}, + [retPropsType; innerType] ) + in + let newStructure = + { + psig with + psig_desc = + Psig_value + { + psig_desc with + pval_type = {pval_type with ptyp_desc = newExternalType}; + pval_attributes = List.filter otherAttrsPure pval_attributes; + }; + } + in + externalPropsDecl :: newStructure :: returnSignatures + | _ -> + raise + (Invalid_argument + "Only one react.component call can exist on a component at one \ + time")) | signature -> signature :: returnSignatures [@@raises Invalid_argument] in @@ -811,78 +1145,112 @@ let jsxMapper () = let transformJsxCall mapper callExpression callArguments attrs = match callExpression.pexp_desc with | Pexp_ident caller -> ( - match caller with - | { txt = Lident "createElement" } -> - raise (Invalid_argument "JSX: `createElement` should be preceeded by a module name.") - (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) - | { loc; txt = Ldot (modulePath, ("createElement" | "make")) } -> ( - match !jsxVersion with - | None | Some 3 -> transformUppercaseCall3 modulePath mapper loc attrs callExpression callArguments - | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3") ) - (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) - (* turn that into - ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) - | { loc; txt = Lident id } -> ( - match !jsxVersion with - | None | Some 3 -> transformLowercaseCall3 mapper loc attrs callArguments id - | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3") ) - | { txt = Ldot (_, anythingNotCreateElementOrMake) } -> - raise - (Invalid_argument - ( "JSX: the JSX attribute should be attached to a `YourModuleName.createElement` or \ - `YourModuleName.make` call. We saw `" ^ anythingNotCreateElementOrMake ^ "` instead" )) - | { txt = Lapply _ } -> - (* don't think there's ever a case where this is reached *) - raise (Invalid_argument "JSX: encountered a weird case while processing the code. Please report this!") ) - | _ -> raise (Invalid_argument "JSX: `createElement` should be preceeded by a simple, direct module name.") + match caller with + | {txt = Lident "createElement"} -> + raise + (Invalid_argument + "JSX: `createElement` should be preceeded by a module name.") + (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> ( + match !jsxVersion with + | None | Some 3 -> + transformUppercaseCall3 modulePath mapper loc attrs callExpression + callArguments + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3")) + (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) + (* turn that into + ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) + | {loc; txt = Lident id} -> ( + match !jsxVersion with + | None | Some 3 -> + transformLowercaseCall3 mapper loc attrs callArguments id + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3")) + | {txt = Ldot (_, anythingNotCreateElementOrMake)} -> + raise + (Invalid_argument + ("JSX: the JSX attribute should be attached to a \ + `YourModuleName.createElement` or `YourModuleName.make` call. \ + We saw `" ^ anythingNotCreateElementOrMake ^ "` instead")) + | {txt = Lapply _} -> + (* don't think there's ever a case where this is reached *) + raise + (Invalid_argument + "JSX: encountered a weird case while processing the code. Please \ + report this!")) + | _ -> + raise + (Invalid_argument + "JSX: `createElement` should be preceeded by a simple, direct \ + module name.") [@@raises Invalid_argument] in let signature mapper signature = - default_mapper.signature mapper @@ reactComponentSignatureTransform mapper signature + default_mapper.signature mapper + @@ reactComponentSignatureTransform mapper signature [@@raises Invalid_argument] in let structure mapper structure = - match structure with structures -> default_mapper.structure mapper @@ reactComponentTransform mapper structures + match structure with + | structures -> + default_mapper.structure mapper + @@ reactComponentTransform mapper structures [@@raises Invalid_argument] in let expr mapper expression = match expression with (* Does the function application have the @JSX attribute? *) - | { pexp_desc = Pexp_apply (callExpression, callArguments); pexp_attributes } -> ( - let jsxAttribute, nonJSXAttributes = - List.partition (fun (attribute, _) -> attribute.txt = "JSX") pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> transformJsxCall mapper callExpression callArguments nonJSXAttributes ) + | {pexp_desc = Pexp_apply (callExpression, callArguments); pexp_attributes} + -> ( + let jsxAttribute, nonJSXAttributes = + List.partition + (fun (attribute, _) -> attribute.txt = "JSX") + pexp_attributes + in + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + transformJsxCall mapper callExpression callArguments nonJSXAttributes) (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) | { pexp_desc = - ( Pexp_construct ({ txt = Lident "::"; loc }, Some { pexp_desc = Pexp_tuple _ }) - | Pexp_construct ({ txt = Lident "[]"; loc }, None) ); + ( Pexp_construct + ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _}) + | Pexp_construct ({txt = Lident "[]"; loc}, None) ); pexp_attributes; } as listItems -> ( - let jsxAttribute, nonJSXAttributes = - List.partition (fun (attribute, _) -> attribute.txt = "JSX") pexp_attributes + let jsxAttribute, nonJSXAttributes = + List.partition + (fun (attribute, _) -> attribute.txt = "JSX") + pexp_attributes + in + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + let loc = {loc with loc_ghost = true} in + let fragment = + Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "fragment")} in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - let loc = {loc with loc_ghost= true} in - let fragment = Exp.ident ~loc { loc; txt = Ldot (Lident "ReasonReact", "fragment") } in - let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in - let args = - [ (* "div" *) (nolabel, fragment); (* [|moreCreateElementCallsHere|] *) (nolabel, childrenExpr) ] - in - Exp.apply ~loc (* throw away the [@JSX] attribute and keep the others, if any *) ~attrs:nonJSXAttributes - (* ReactDOMRe.createElement *) - (Exp.ident ~loc { loc; txt = Ldot (Lident "ReactDOMRe", "createElement") }) - args ) + let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in + let args = + [ + (* "div" *) + (nolabel, fragment); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] + in + Exp.apply + ~loc (* throw away the [@JSX] attribute and keep the others, if any *) + ~attrs:nonJSXAttributes + (* ReactDOMRe.createElement *) + (Exp.ident ~loc + {loc; txt = Ldot (Lident "ReactDOMRe", "createElement")}) + args) (* Delegate to the default mapper, a deep identity traversal *) | e -> default_mapper.expr mapper e [@@raises Invalid_argument] @@ -895,7 +1263,7 @@ let jsxMapper () = mapped [@@raises Failure] in - { default_mapper with structure; expr; signature; module_binding } + {default_mapper with structure; expr; signature; module_binding} [@@raises Invalid_argument, Failure] let rewrite_implementation (code : Parsetree.structure) : Parsetree.structure = diff --git a/cli/res_cli.ml b/cli/res_cli.ml index b156c9cf..a11bf162 100644 --- a/cli/res_cli.ml +++ b/cli/res_cli.ml @@ -35,7 +35,6 @@ module Color = struct | Magenta | Cyan | White [@live] - ;; type style = | FG of color (* foreground *) @@ -62,40 +61,36 @@ module Color = struct | Dim -> "2" let ansi_of_style_l l = - let s = match l with + let s = + match l with | [] -> code_of_style Reset | [s] -> code_of_style s | _ -> String.concat ";" (List.map code_of_style l) in "\x1b[" ^ s ^ "m" - type styles = { - error: style list; - warning: style list; - loc: style list; - } + type styles = {error: style list; warning: style list; loc: style list} - let default_styles = { - warning = [Bold; FG Magenta]; - error = [Bold; FG Red]; - loc = [Bold]; - } + let default_styles = + {warning = [Bold; FG Magenta]; error = [Bold; FG Red]; loc = [Bold]} let cur_styles = ref default_styles + (* let get_styles () = !cur_styles *) (* let set_styles s = cur_styles := s *) (* map a tag to a style, if the tag is known. @raise Not_found otherwise *) - let style_of_tag s = match s with - | "error" -> (!cur_styles).error - | "warning" -> (!cur_styles).warning - | "loc" -> (!cur_styles).loc + let style_of_tag s = + match s with + | "error" -> !cur_styles.error + | "warning" -> !cur_styles.warning + | "loc" -> !cur_styles.loc | "info" -> [Bold; FG Yellow] | "dim" -> [Dim] | "filename" -> [FG Cyan] | _ -> raise Not_found - [@@raises Not_found] + [@@raises Not_found] let color_enabled = ref true @@ -116,14 +111,18 @@ module Color = struct let set_color_tag_handling ppf = let open Format in let functions = pp_get_formatter_tag_functions ppf () in - let functions' = {functions with - mark_open_tag=(mark_open_tag ~or_else:functions.mark_open_tag); - mark_close_tag=(mark_close_tag ~or_else:functions.mark_close_tag); - } in - pp_set_mark_tags ppf true; (* enable tags *) + let functions' = + { + functions with + mark_open_tag = mark_open_tag ~or_else:functions.mark_open_tag; + mark_close_tag = mark_close_tag ~or_else:functions.mark_close_tag; + } + in + pp_set_mark_tags ppf true; + (* enable tags *) pp_set_formatter_tag_functions ppf functions'; (* also setup margins *) - pp_set_margin ppf (pp_get_margin std_formatter()); + pp_set_margin ppf (pp_get_margin std_formatter ()); () external isatty : out_channel -> bool = "caml_sys_isatty" @@ -131,14 +130,13 @@ module Color = struct (* reasonable heuristic on whether colors should be enabled *) let should_enable_color () = let term = try Sys.getenv "TERM" with Not_found -> "" in - term <> "dumb" - && term <> "" - && isatty stderr + term <> "dumb" && term <> "" && isatty stderr type setting = Auto [@live] | Always [@live] | Never [@live] let setup = - let first = ref true in (* initialize only once *) + let first = ref true in + (* initialize only once *) let formatter_l = [Format.std_formatter; Format.err_formatter; Format.str_formatter] in @@ -147,27 +145,27 @@ module Color = struct first := false; Format.set_mark_tags true; List.iter set_color_tag_handling formatter_l; - color_enabled := (match o with - | Some Always -> true - | Some Auto -> should_enable_color () - | Some Never -> false - | None -> should_enable_color ()) - ); + color_enabled := + match o with + | Some Always -> true + | Some Auto -> should_enable_color () + | Some Never -> false + | None -> should_enable_color ()); () end (* command line flags *) -module ResClflags: sig - val recover: bool ref - val print: string ref - val width: int ref - val origin: string ref - val file: string ref - val interface: bool ref - val ppx: string ref - val typechecker: bool ref - - val parse: unit -> unit +module ResClflags : sig + val recover : bool ref + val print : string ref + val width : int ref + val origin : string ref + val file : string ref + val interface : bool ref + val ppx : string ref + val typechecker : bool ref + + val parse : unit -> unit end = struct let recover = ref false let width = ref 100 @@ -179,34 +177,53 @@ end = struct let file = ref "" let typechecker = ref false - let usage = "\n**This command line is for the repo developer's testing purpose only. DO NOT use it in production**!\n\n" ^ - "Usage:\n rescript \n\n" ^ - "Examples:\n" ^ - " rescript myFile.res\n" ^ - " rescript -parse ml -print res myFile.ml\n" ^ - " rescript -parse res -print binary -interface myFile.resi\n\n" ^ - "Options are:" - - let spec = [ - ("-recover", Arg.Unit (fun () -> recover := true), "Emit partial ast"); - ("-parse", Arg.String (fun txt -> origin := txt), "Parse reasonBinary, ml or res. Default: res"); - ("-print", Arg.String (fun txt -> print := txt), "Print either binary, ml, ast, sexp, comments or res. Default: res"); - ("-width", Arg.Int (fun w -> width := w), "Specify the line length for the printer (formatter)"); - ("-interface", Arg.Unit (fun () -> interface := true), "Parse as interface"); - ("-ppx", Arg.String (fun txt -> ppx := txt), "Apply a specific built-in ppx before parsing, none or jsx. Default: none"); - ("-typechecker", Arg.Unit (fun () -> typechecker := true), "Parses the ast as it would be passed to the typechecker and not the printer") - ] + let usage = + "\n\ + **This command line is for the repo developer's testing purpose only. DO \ + NOT use it in production**!\n\n" + ^ "Usage:\n rescript \n\n" ^ "Examples:\n" + ^ " rescript myFile.res\n" ^ " rescript -parse ml -print res myFile.ml\n" + ^ " rescript -parse res -print binary -interface myFile.resi\n\n" + ^ "Options are:" + + let spec = + [ + ("-recover", Arg.Unit (fun () -> recover := true), "Emit partial ast"); + ( "-parse", + Arg.String (fun txt -> origin := txt), + "Parse reasonBinary, ml or res. Default: res" ); + ( "-print", + Arg.String (fun txt -> print := txt), + "Print either binary, ml, ast, sexp, comments or res. Default: res" ); + ( "-width", + Arg.Int (fun w -> width := w), + "Specify the line length for the printer (formatter)" ); + ( "-interface", + Arg.Unit (fun () -> interface := true), + "Parse as interface" ); + ( "-ppx", + Arg.String (fun txt -> ppx := txt), + "Apply a specific built-in ppx before parsing, none or jsx. Default: \ + none" ); + ( "-typechecker", + Arg.Unit (fun () -> typechecker := true), + "Parses the ast as it would be passed to the typechecker and not the \ + printer" ); + ] let parse () = Arg.parse spec (fun f -> file := f) usage end module CliArgProcessor = struct - type backend = Parser: ('diagnostics) Res_driver.parsingEngine -> backend [@@unboxed] + type backend = Parser : 'diagnostics Res_driver.parsingEngine -> backend + [@@unboxed] - let processFile ~isInterface ~width ~recover ~origin ~target ~ppx ~typechecker filename = + let processFile ~isInterface ~width ~recover ~origin ~target ~ppx ~typechecker + filename = let len = String.length filename in let processInterface = - isInterface || len > 0 && (String.get [@doesNotRaise]) filename (len - 1) = 'i' + isInterface + || (len > 0 && (String.get [@doesNotRaise]) filename (len - 1) = 'i') in let parsingEngine = match origin with @@ -217,10 +234,11 @@ module CliArgProcessor = struct match Filename.extension filename with | ".ml" | ".mli" -> Parser Res_driver_ml_parser.parsingEngine | ".re" | ".rei" -> Parser Res_driver_reason_binary.parsingEngine - | _ -> Parser Res_driver.parsingEngine - ) + | _ -> Parser Res_driver.parsingEngine) | origin -> - print_endline ("-parse needs to be either reasonBinary, ml or res. You provided " ^ origin); + print_endline + ("-parse needs to be either reasonBinary, ml or res. You provided " + ^ origin); exit 1 in let printEngine = @@ -230,72 +248,65 @@ module CliArgProcessor = struct | "ast" -> Res_ast_debugger.printEngine | "sexp" -> Res_ast_debugger.sexpPrintEngine | "comments" -> Res_ast_debugger.commentsPrintEngine - | "res" -> Res_driver.printEngine + | "res" -> Res_driver.printEngine | target -> - print_endline ("-print needs to be either binary, ml, ast, sexp, comments or res. You provided " ^ target); + print_endline + ("-print needs to be either binary, ml, ast, sexp, comments or res. \ + You provided " ^ target); exit 1 in - let forPrinter = match target with - | "res" | "sexp" when not typechecker -> true - | _ -> false + let forPrinter = + match target with + | ("res" | "sexp") when not typechecker -> true + | _ -> false in - let Parser backend = parsingEngine in + let (Parser backend) = parsingEngine in (* This is the whole purpose of the Color module above *) Color.setup None; if processInterface then let parseResult = backend.parseInterface ~forPrinter ~filename in - if parseResult.invalid then begin - backend.stringOfDiagnostics - ~source:parseResult.source - ~filename:parseResult.filename - parseResult.diagnostics; + if parseResult.invalid then ( + backend.stringOfDiagnostics ~source:parseResult.source + ~filename:parseResult.filename parseResult.diagnostics; if recover then - printEngine.printInterface - ~width ~filename ~comments:parseResult.comments parseResult.parsetree - else exit 1 - end + printEngine.printInterface ~width ~filename + ~comments:parseResult.comments parseResult.parsetree + else exit 1) else - let parsetree = match ppx with + let parsetree = + match ppx with | "jsx" -> Reactjs_jsx_ppx_v3.rewrite_signature parseResult.parsetree | _ -> parseResult.parsetree in - printEngine.printInterface - ~width ~filename ~comments:parseResult.comments parsetree + printEngine.printInterface ~width ~filename + ~comments:parseResult.comments parsetree else let parseResult = backend.parseImplementation ~forPrinter ~filename in - if parseResult.invalid then begin - backend.stringOfDiagnostics - ~source:parseResult.source - ~filename:parseResult.filename - parseResult.diagnostics; + if parseResult.invalid then ( + backend.stringOfDiagnostics ~source:parseResult.source + ~filename:parseResult.filename parseResult.diagnostics; if recover then - printEngine.printImplementation - ~width ~filename ~comments:parseResult.comments parseResult.parsetree - else exit 1 - end + printEngine.printImplementation ~width ~filename + ~comments:parseResult.comments parseResult.parsetree + else exit 1) else - let parsetree = match ppx with - | "jsx" -> Reactjs_jsx_ppx_v3.rewrite_implementation parseResult.parsetree + let parsetree = + match ppx with + | "jsx" -> + Reactjs_jsx_ppx_v3.rewrite_implementation parseResult.parsetree | _ -> parseResult.parsetree in - printEngine.printImplementation - ~width ~filename ~comments:parseResult.comments parsetree - [@@raises exit] + printEngine.printImplementation ~width ~filename + ~comments:parseResult.comments parsetree + [@@raises exit] end - -let [@raises exit] () = - if not !Sys.interactive then begin +let[@raises exit] () = + if not !Sys.interactive then ( ResClflags.parse (); - CliArgProcessor.processFile - ~isInterface:!ResClflags.interface - ~width:!ResClflags.width - ~recover:!ResClflags.recover - ~target:!ResClflags.print - ~origin:!ResClflags.origin - ~ppx:!ResClflags.ppx - ~typechecker:!ResClflags.typechecker - !ResClflags.file -end + CliArgProcessor.processFile ~isInterface:!ResClflags.interface + ~width:!ResClflags.width ~recover:!ResClflags.recover + ~target:!ResClflags.print ~origin:!ResClflags.origin ~ppx:!ResClflags.ppx + ~typechecker:!ResClflags.typechecker !ResClflags.file) diff --git a/src/res_ast_conversion.ml b/src/res_ast_conversion.ml index 39a2029e..419e8ae7 100644 --- a/src/res_ast_conversion.ml +++ b/src/res_ast_conversion.ml @@ -1,4 +1,3 @@ - let concatLongidents l1 l2 = let parts1 = Longident.flatten l1 in let parts2 = Longident.flatten l2 in @@ -9,52 +8,69 @@ let concatLongidents l1 l2 = (* TODO: support nested open's ? *) let rec rewritePpatOpen longidentOpen pat = match pat.Parsetree.ppat_desc with - | Ppat_array (first::rest) -> + | Ppat_array (first :: rest) -> (* Color.[Red, Blue, Green] -> [Color.Red, Blue, Green] *) - {pat with ppat_desc = Ppat_array ((rewritePpatOpen longidentOpen first)::rest)} - | Ppat_tuple (first::rest) -> + { + pat with + ppat_desc = Ppat_array (rewritePpatOpen longidentOpen first :: rest); + } + | Ppat_tuple (first :: rest) -> (* Color.(Red, Blue, Green) -> (Color.Red, Blue, Green) *) - {pat with ppat_desc = Ppat_tuple ((rewritePpatOpen longidentOpen first)::rest)} - | Ppat_construct( - {txt = Longident.Lident "::"} as listConstructor, - Some ({ppat_desc=Ppat_tuple (pat::rest)} as element) - ) -> + { + pat with + ppat_desc = Ppat_tuple (rewritePpatOpen longidentOpen first :: rest); + } + | Ppat_construct + ( ({txt = Longident.Lident "::"} as listConstructor), + Some ({ppat_desc = Ppat_tuple (pat :: rest)} as element) ) -> (* Color.(list[Red, Blue, Green]) -> list[Color.Red, Blue, Green] *) - {pat with ppat_desc = - Ppat_construct ( - listConstructor, - Some {element with ppat_desc = Ppat_tuple ((rewritePpatOpen longidentOpen pat)::rest)} - ) + { + pat with + ppat_desc = + Ppat_construct + ( listConstructor, + Some + { + element with + ppat_desc = + Ppat_tuple (rewritePpatOpen longidentOpen pat :: rest); + } ); } - | Ppat_construct ({txt = constructor} as longidentLoc, optPattern) -> + | Ppat_construct (({txt = constructor} as longidentLoc), optPattern) -> (* Foo.(Bar(a)) -> Foo.Bar(a) *) - {pat with ppat_desc = - Ppat_construct ( - {longidentLoc with txt = concatLongidents longidentOpen constructor}, - optPattern - ) + { + pat with + ppat_desc = + Ppat_construct + ( {longidentLoc with txt = concatLongidents longidentOpen constructor}, + optPattern ); } - | Ppat_record (({txt = lbl} as longidentLoc, firstPat)::rest, flag) -> + | Ppat_record ((({txt = lbl} as longidentLoc), firstPat) :: rest, flag) -> (* Foo.{x} -> {Foo.x: x} *) - let firstRow = ( - {longidentLoc with txt = concatLongidents longidentOpen lbl}, - firstPat - ) in - {pat with ppat_desc = Ppat_record (firstRow::rest, flag)} + let firstRow = + ({longidentLoc with txt = concatLongidents longidentOpen lbl}, firstPat) + in + {pat with ppat_desc = Ppat_record (firstRow :: rest, flag)} | Ppat_or (pat1, pat2) -> - {pat with ppat_desc = Ppat_or ( - rewritePpatOpen longidentOpen pat1, - rewritePpatOpen longidentOpen pat2 - )} + { + pat with + ppat_desc = + Ppat_or + ( rewritePpatOpen longidentOpen pat1, + rewritePpatOpen longidentOpen pat2 ); + } | Ppat_constraint (pattern, typ) -> - {pat with ppat_desc = Ppat_constraint ( - rewritePpatOpen longidentOpen pattern, - typ - )} + { + pat with + ppat_desc = Ppat_constraint (rewritePpatOpen longidentOpen pattern, typ); + } | Ppat_type ({txt = constructor} as longidentLoc) -> - {pat with ppat_desc = Ppat_type ( - {longidentLoc with txt = concatLongidents longidentOpen constructor} - )} + { + pat with + ppat_desc = + Ppat_type + {longidentLoc with txt = concatLongidents longidentOpen constructor}; + } | Ppat_lazy p -> {pat with ppat_desc = Ppat_lazy (rewritePpatOpen longidentOpen p)} | Ppat_exception p -> @@ -64,74 +80,91 @@ let rec rewritePpatOpen longidentOpen pat = let rec rewriteReasonFastPipe expr = let open Parsetree in match expr.pexp_desc with - | Pexp_apply ( - {pexp_desc = Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "|."}} as op, - [Asttypes.Nolabel, lhs; Nolabel, rhs] - ); pexp_attributes = subAttrs}, - args - ) -> + | Pexp_apply + ( { + pexp_desc = + Pexp_apply + ( ({pexp_desc = Pexp_ident {txt = Longident.Lident "|."}} as op), + [(Asttypes.Nolabel, lhs); (Nolabel, rhs)] ); + pexp_attributes = subAttrs; + }, + args ) -> let rhsLoc = {rhs.pexp_loc with loc_end = expr.pexp_loc.loc_end} in let newLhs = let expr = rewriteReasonFastPipe lhs in {expr with pexp_attributes = List.concat [lhs.pexp_attributes; subAttrs]} in - let newRhs = { - pexp_loc = rhsLoc; - pexp_attributes = []; - pexp_desc = Pexp_apply (rhs, args) - } in - let allArgs = (Asttypes.Nolabel, newLhs)::[(Asttypes.Nolabel, newRhs)] in + let newRhs = + { + pexp_loc = rhsLoc; + pexp_attributes = []; + pexp_desc = Pexp_apply (rhs, args); + } + in + let allArgs = (Asttypes.Nolabel, newLhs) :: [(Asttypes.Nolabel, newRhs)] in {expr with pexp_desc = Pexp_apply (op, allArgs)} | _ -> expr let makeReasonArityMapper ~forPrinter = let open Ast_mapper in - { default_mapper with - expr = begin fun mapper expr -> - match expr with - (* Don't mind this case, Reason doesn't handle this. *) - (* | {pexp_desc = Pexp_variant (lbl, args); pexp_loc; pexp_attributes} -> *) + { + default_mapper with + expr = + (fun mapper expr -> + match expr with + (* Don't mind this case, Reason doesn't handle this. *) + (* | {pexp_desc = Pexp_variant (lbl, args); pexp_loc; pexp_attributes} -> *) (* let newArgs = match args with *) (* | (Some {pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _ } as sp]}) as args-> *) - (* if forPrinter then args else Some sp *) + (* if forPrinter then args else Some sp *) (* | Some {pexp_desc = Pexp_tuple [sp]} -> Some sp *) (* | _ -> args *) (* in *) (* default_mapper.expr mapper {pexp_desc=Pexp_variant(lbl, newArgs); pexp_loc; pexp_attributes} *) - | {pexp_desc=Pexp_construct(lid, args); pexp_loc; pexp_attributes} -> - let newArgs = match args with - | (Some {pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _ } as sp]}) as args -> - if forPrinter then args else Some sp - | Some {pexp_desc = Pexp_tuple [sp]} -> Some sp - | _ -> args - in - default_mapper.expr mapper { pexp_desc=Pexp_construct(lid, newArgs); pexp_loc; pexp_attributes} - | expr -> - default_mapper.expr mapper (rewriteReasonFastPipe expr) - end; - pat = begin fun mapper pattern -> - match pattern with - (* Don't mind this case, Reason doesn't handle this. *) - (* | {ppat_desc = Ppat_variant (lbl, args); ppat_loc; ppat_attributes} -> *) + | {pexp_desc = Pexp_construct (lid, args); pexp_loc; pexp_attributes} -> + let newArgs = + match args with + | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as sp)]} + as args -> + if forPrinter then args else Some sp + | Some {pexp_desc = Pexp_tuple [sp]} -> Some sp + | _ -> args + in + default_mapper.expr mapper + { + pexp_desc = Pexp_construct (lid, newArgs); + pexp_loc; + pexp_attributes; + } + | expr -> default_mapper.expr mapper (rewriteReasonFastPipe expr)); + pat = + (fun mapper pattern -> + match pattern with + (* Don't mind this case, Reason doesn't handle this. *) + (* | {ppat_desc = Ppat_variant (lbl, args); ppat_loc; ppat_attributes} -> *) (* let newArgs = match args with *) (* | (Some {ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as sp]}) as args -> *) - (* if forPrinter then args else Some sp *) + (* if forPrinter then args else Some sp *) (* | Some {ppat_desc = Ppat_tuple [sp]} -> Some sp *) (* | _ -> args *) (* in *) (* default_mapper.pat mapper {ppat_desc = Ppat_variant (lbl, newArgs); ppat_loc; ppat_attributes;} *) - | {ppat_desc=Ppat_construct(lid, args); - ppat_loc; - ppat_attributes} -> - let new_args = match args with - | (Some {ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as sp]}) as args -> - if forPrinter then args else Some sp - | Some {ppat_desc = Ppat_tuple [sp]} -> Some sp - | _ -> args in - default_mapper.pat mapper { ppat_desc=Ppat_construct(lid, new_args); ppat_loc; ppat_attributes;} - | x -> default_mapper.pat mapper x - end; + | {ppat_desc = Ppat_construct (lid, args); ppat_loc; ppat_attributes} -> + let new_args = + match args with + | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as sp)]} + as args -> + if forPrinter then args else Some sp + | Some {ppat_desc = Ppat_tuple [sp]} -> Some sp + | _ -> args + in + default_mapper.pat mapper + { + ppat_desc = Ppat_construct (lid, new_args); + ppat_loc; + ppat_attributes; + } + | x -> default_mapper.pat mapper x); } let escapeTemplateLiteral s = @@ -143,31 +176,28 @@ let escapeTemplateLiteral s = if c = '`' then ( Buffer.add_char b '\\'; Buffer.add_char b '`'; - incr i; - ) else if c = '$' then ( + incr i) + else if c = '$' then if !i + 1 < len then ( let c2 = (String.get [@doesNotRaise]) s (!i + 1) in if c2 = '{' then ( Buffer.add_char b '\\'; Buffer.add_char b '$'; - Buffer.add_char b '{'; - ) else ( + Buffer.add_char b '{') + else ( Buffer.add_char b c; - Buffer.add_char b c2; - ); - i := !i + 2; - ) else ( + Buffer.add_char b c2); + i := !i + 2) + else ( Buffer.add_char b c; - incr i - ) - ) else if c = '\\' then ( + incr i) + else if c = '\\' then ( Buffer.add_char b '\\'; Buffer.add_char b '\\'; - incr i; - ) else ( + incr i) + else ( Buffer.add_char b c; - incr i - ) + incr i) done; Buffer.contents b @@ -186,16 +216,14 @@ let escapeStringContents s = if !i < len then let () = Buffer.add_char b c in incr i - else - () - ) else if c = '"' then ( + else ()) + else if c = '"' then ( Buffer.add_char b '\\'; Buffer.add_char b c; - incr i; - ) else ( + incr i) + else ( Buffer.add_char b c; - incr i; - ) + incr i) done; Buffer.contents b @@ -209,76 +237,60 @@ let looksLikeRecursiveTypeDeclaration typeDeclaration = List.exists checkConstructorDeclaration constructorDeclarations | Ptype_record labelDeclarations -> List.exists checkLabelDeclaration labelDeclarations - and checkConstructorDeclaration constrDecl = checkConstructorArguments constrDecl.pcd_args - || (match constrDecl.pcd_res with - | Some typexpr -> - checkTypExpr typexpr + || + match constrDecl.pcd_res with + | Some typexpr -> checkTypExpr typexpr | None -> false - ) - and checkLabelDeclaration labelDeclaration = checkTypExpr labelDeclaration.pld_type - and checkConstructorArguments constrArg = match constrArg with - | Pcstr_tuple types -> - List.exists checkTypExpr types + | Pcstr_tuple types -> List.exists checkTypExpr types | Pcstr_record labelDeclarations -> List.exists checkLabelDeclaration labelDeclarations - and checkTypExpr typ = match typ.ptyp_desc with | Ptyp_any -> false | Ptyp_var _ -> false - | Ptyp_object (fields, _) -> - List.exists checkObjectField fields + | Ptyp_object (fields, _) -> List.exists checkObjectField fields | Ptyp_class _ -> false | Ptyp_package _ -> false | Ptyp_extension _ -> false - | Ptyp_arrow (_lbl, typ1, typ2) -> - checkTypExpr typ1 || checkTypExpr typ2 - | Ptyp_tuple types -> - List.exists checkTypExpr types + | Ptyp_arrow (_lbl, typ1, typ2) -> checkTypExpr typ1 || checkTypExpr typ2 + | Ptyp_tuple types -> List.exists checkTypExpr types | Ptyp_constr ({txt = longident}, types) -> (match longident with | Lident ident -> ident = name - | _ -> false - ) || - List.exists checkTypExpr types + | _ -> false) + || List.exists checkTypExpr types | Ptyp_alias (typ, _) -> checkTypExpr typ - | Ptyp_variant (rowFields, _, _) -> - List.exists checkRowFields rowFields - | Ptyp_poly (_, typ) -> - checkTypExpr typ - - and checkObjectField field = match field with + | Ptyp_variant (rowFields, _, _) -> List.exists checkRowFields rowFields + | Ptyp_poly (_, typ) -> checkTypExpr typ + and checkObjectField field = + match field with | Otag (_label, _attrs, typ) -> checkTypExpr typ | Oinherit typ -> checkTypExpr typ - and checkRowFields rowField = match rowField with - | Rtag (_, _, _, types) -> - List.exists checkTypExpr types - | Rinherit typexpr -> - checkTypExpr typexpr - + | Rtag (_, _, _, types) -> List.exists checkTypExpr types + | Rinherit typexpr -> checkTypExpr typexpr and checkManifest manifest = match manifest with - | Some typ -> - checkTypExpr typ + | Some typ -> checkTypExpr typ | None -> false in - checkKind typeDeclaration.ptype_kind || checkManifest typeDeclaration.ptype_manifest - + checkKind typeDeclaration.ptype_kind + || checkManifest typeDeclaration.ptype_manifest let filterReasonRawLiteral attrs = - List.filter (fun attr -> - match attr with - | ({Location.txt = ("reason.raw_literal")}, _) -> false - | _ -> true - ) attrs + List.filter + (fun attr -> + match attr with + | {Location.txt = "reason.raw_literal"}, _ -> false + | _ -> true) + attrs let stringLiteralMapper stringData = let isSameLocation l1 l2 = @@ -287,282 +299,376 @@ let stringLiteralMapper stringData = in let remainingStringData = stringData in let open Ast_mapper in - { default_mapper with - expr = (fun mapper expr -> - match expr.pexp_desc with - | Pexp_constant (Pconst_string (_txt, None)) -> - begin match - List.find_opt (fun (_stringData, stringLoc) -> - isSameLocation stringLoc expr.pexp_loc - ) remainingStringData - with - | Some(stringData, _) -> - let stringData = - let attr = List.find_opt (fun attr -> match attr with - | ({Location.txt = ("reason.raw_literal")}, _) -> true - | _ -> false - ) expr.pexp_attributes in - match attr with - | Some (_, PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (raw, _))}, _)}]) -> - raw - | _ -> (String.sub [@doesNotRaise]) stringData 1 (String.length stringData - 2) + { + default_mapper with + expr = + (fun mapper expr -> + match expr.pexp_desc with + | Pexp_constant (Pconst_string (_txt, None)) -> ( + match + List.find_opt + (fun (_stringData, stringLoc) -> + isSameLocation stringLoc expr.pexp_loc) + remainingStringData + with + | Some (stringData, _) -> + let stringData = + let attr = + List.find_opt + (fun attr -> + match attr with + | {Location.txt = "reason.raw_literal"}, _ -> true + | _ -> false) + expr.pexp_attributes + in + match attr with + | Some + ( _, + PStr + [ + { + pstr_desc = + Pstr_eval + ( { + pexp_desc = + Pexp_constant (Pconst_string (raw, _)); + }, + _ ); + }; + ] ) -> + raw + | _ -> + (String.sub [@doesNotRaise]) stringData 1 + (String.length stringData - 2) in - {expr with - pexp_attributes = filterReasonRawLiteral expr.pexp_attributes; - pexp_desc = Pexp_constant (Pconst_string (stringData, None)) - } - | None -> - default_mapper.expr mapper expr - end - | _ -> default_mapper.expr mapper expr - ) + { + expr with + pexp_attributes = filterReasonRawLiteral expr.pexp_attributes; + pexp_desc = Pexp_constant (Pconst_string (stringData, None)); + } + | None -> default_mapper.expr mapper expr) + | _ -> default_mapper.expr mapper expr); } -let hasUncurriedAttribute attrs = List.exists (fun attr -> match attr with - | ({Asttypes.txt = "bs"}, Parsetree.PStr []) -> true - | _ -> false -) attrs +let hasUncurriedAttribute attrs = + List.exists + (fun attr -> + match attr with + | {Asttypes.txt = "bs"}, Parsetree.PStr [] -> true + | _ -> false) + attrs let templateLiteralAttr = (Location.mknoloc "res.template", Parsetree.PStr []) let normalize = let open Ast_mapper in - { default_mapper with - extension = (fun mapper ext -> - match ext with - | (id, payload) -> - ( - {id with txt = Res_printer.convertBsExtension id.txt}, - default_mapper.payload mapper payload - ) - ); - attribute = (fun mapper attr -> - match attr with - | (id, payload) -> - ( - {id with txt = Res_printer.convertBsExternalAttribute id.txt}, - default_mapper.payload mapper payload - ) - ); - attributes = (fun mapper attrs -> - attrs - |> List.filter (fun attr -> + { + default_mapper with + extension = + (fun mapper ext -> + match ext with + | id, payload -> + ( {id with txt = Res_printer.convertBsExtension id.txt}, + default_mapper.payload mapper payload )); + attribute = + (fun mapper attr -> match attr with - | ({Location.txt = ( - "reason.preserve_braces" - | "explicit_arity" - | "implicity_arity" - )}, _) -> false - | _ ->true - ) - |> default_mapper.attributes mapper - ); - pat = begin fun mapper p -> - match p.ppat_desc with - | Ppat_open ({txt = longidentOpen}, pattern) -> - let p = rewritePpatOpen longidentOpen pattern in - default_mapper.pat mapper p - | Ppat_constant (Pconst_string (txt, tag)) -> - let newTag = match tag with - (* transform {|abc|} into {js|abc|js}, because `template string` is interpreted as {js||js} *) - | Some "" -> Some "js" - | tag -> tag - in - let s = Parsetree.Pconst_string ((escapeTemplateLiteral txt), newTag) in - {p with - ppat_attributes = templateLiteralAttr::(mapper.attributes mapper p.ppat_attributes); - ppat_desc = Ppat_constant s - } - | _ -> - default_mapper.pat mapper p - end; - typ = (fun mapper typ -> - match typ.ptyp_desc with - | Ptyp_constr({txt = Longident.Ldot(Longident.Lident "Js", "t")}, [arg]) -> - (* Js.t({"a": b}) -> {"a": b} - Since compiler >9.0.1 objects don't need Js.t wrapping anymore *) - mapper.typ mapper arg - | _ -> default_mapper.typ mapper typ - ); - expr = (fun mapper expr -> - match expr.pexp_desc with - | Pexp_constant (Pconst_string (txt, None)) -> - let raw = escapeStringContents txt in - let s = Parsetree.Pconst_string (raw, None) in - {expr with pexp_desc = Pexp_constant s} - | Pexp_constant (Pconst_string (txt, tag)) -> - let newTag = match tag with - (* transform {|abc|} into {js|abc|js}, we want to preserve unicode by default *) - | Some "" -> Some "js" - | tag -> tag - in - let s = Parsetree.Pconst_string ((escapeTemplateLiteral txt), newTag) in - {expr with - pexp_attributes= templateLiteralAttr::(mapper.attributes mapper expr.pexp_attributes); - pexp_desc = Pexp_constant s - } - | Pexp_apply ( - callExpr, - [ - Nolabel, - ({pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None); pexp_attributes = []} as unitExpr) - ] - ) when hasUncurriedAttribute expr.pexp_attributes - -> - {expr with - pexp_attributes = mapper.attributes mapper expr.pexp_attributes; - pexp_desc = Pexp_apply ( - callExpr, - [Nolabel, {unitExpr with pexp_loc = {unitExpr.pexp_loc with loc_ghost = true}}] - ) - } - | Pexp_function cases -> - let loc = match (cases, List.rev cases) with - | (first::_), (last::_) -> - {first.pc_lhs.ppat_loc with loc_end = last.pc_rhs.pexp_loc.loc_end} - | _ -> Location.none - in - let var = { - Parsetree.ppat_loc = Location.none; - ppat_attributes = []; - ppat_desc = Ppat_var (Location.mknoloc "x"); - } in - { - pexp_loc = loc; - pexp_attributes = []; - pexp_desc = Pexp_fun ( - Asttypes.Nolabel, - None, - var, + | id, payload -> + ( {id with txt = Res_printer.convertBsExternalAttribute id.txt}, + default_mapper.payload mapper payload )); + attributes = + (fun mapper attrs -> + attrs + |> List.filter (fun attr -> + match attr with + | ( { + Location.txt = + ( "reason.preserve_braces" | "explicit_arity" + | "implicity_arity" ); + }, + _ ) -> + false + | _ -> true) + |> default_mapper.attributes mapper); + pat = + (fun mapper p -> + match p.ppat_desc with + | Ppat_open ({txt = longidentOpen}, pattern) -> + let p = rewritePpatOpen longidentOpen pattern in + default_mapper.pat mapper p + | Ppat_constant (Pconst_string (txt, tag)) -> + let newTag = + match tag with + (* transform {|abc|} into {js|abc|js}, because `template string` is interpreted as {js||js} *) + | Some "" -> Some "js" + | tag -> tag + in + let s = Parsetree.Pconst_string (escapeTemplateLiteral txt, newTag) in + { + p with + ppat_attributes = + templateLiteralAttr :: mapper.attributes mapper p.ppat_attributes; + ppat_desc = Ppat_constant s; + } + | _ -> default_mapper.pat mapper p); + typ = + (fun mapper typ -> + match typ.ptyp_desc with + | Ptyp_constr + ({txt = Longident.Ldot (Longident.Lident "Js", "t")}, [arg]) -> + (* Js.t({"a": b}) -> {"a": b} + Since compiler >9.0.1 objects don't need Js.t wrapping anymore *) + mapper.typ mapper arg + | _ -> default_mapper.typ mapper typ); + expr = + (fun mapper expr -> + match expr.pexp_desc with + | Pexp_constant (Pconst_string (txt, None)) -> + let raw = escapeStringContents txt in + let s = Parsetree.Pconst_string (raw, None) in + {expr with pexp_desc = Pexp_constant s} + | Pexp_constant (Pconst_string (txt, tag)) -> + let newTag = + match tag with + (* transform {|abc|} into {js|abc|js}, we want to preserve unicode by default *) + | Some "" -> Some "js" + | tag -> tag + in + let s = Parsetree.Pconst_string (escapeTemplateLiteral txt, newTag) in + { + expr with + pexp_attributes = + templateLiteralAttr + :: mapper.attributes mapper expr.pexp_attributes; + pexp_desc = Pexp_constant s; + } + | Pexp_apply + ( callExpr, + [ + ( Nolabel, + ({ + pexp_desc = + Pexp_construct ({txt = Longident.Lident "()"}, None); + pexp_attributes = []; + } as unitExpr) ); + ] ) + when hasUncurriedAttribute expr.pexp_attributes -> + { + expr with + pexp_attributes = mapper.attributes mapper expr.pexp_attributes; + pexp_desc = + Pexp_apply + ( callExpr, + [ + ( Nolabel, + { + unitExpr with + pexp_loc = {unitExpr.pexp_loc with loc_ghost = true}; + } ); + ] ); + } + | Pexp_function cases -> + let loc = + match (cases, List.rev cases) with + | first :: _, last :: _ -> + { + first.pc_lhs.ppat_loc with + loc_end = last.pc_rhs.pexp_loc.loc_end; + } + | _ -> Location.none + in + let var = { - pexp_loc = loc; - pexp_attributes = []; - pexp_desc = Pexp_match ( - { - pexp_loc = Location.none; - pexp_attributes = []; - pexp_desc = Pexp_ident (Location.mknoloc (Longident.Lident "x")) - }, - (mapper.cases mapper cases) - ) - + Parsetree.ppat_loc = Location.none; + ppat_attributes = []; + ppat_desc = Ppat_var (Location.mknoloc "x"); } - ) - } - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "!"}}, - [Asttypes.Nolabel, operand] - ) -> - (* turn `!foo` into `foo.contents` *) - { - pexp_loc = expr.pexp_loc; - pexp_attributes = expr.pexp_attributes; - pexp_desc = Pexp_field (mapper.expr mapper operand, (Location.mknoloc (Longident.Lident "contents"))) - } - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, - [ - Asttypes.Nolabel, lhs; Nolabel, - ({pexp_desc = Pexp_constant (Pconst_string (txt, None)) | (Pexp_ident ({txt = Longident.Lident txt})); pexp_loc = labelLoc})] - ) -> - let label = Location.mkloc txt labelLoc in - { - pexp_loc = expr.pexp_loc; - pexp_attributes = expr.pexp_attributes; - pexp_desc = Pexp_send (mapper.expr mapper lhs, label) + in + { + pexp_loc = loc; + pexp_attributes = []; + pexp_desc = + Pexp_fun + ( Asttypes.Nolabel, + None, + var, + { + pexp_loc = loc; + pexp_attributes = []; + pexp_desc = + Pexp_match + ( { + pexp_loc = Location.none; + pexp_attributes = []; + pexp_desc = + Pexp_ident + (Location.mknoloc (Longident.Lident "x")); + }, + mapper.cases mapper cases ); + } ); + } + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "!"}}, + [(Asttypes.Nolabel, operand)] ) -> + (* turn `!foo` into `foo.contents` *) + { + pexp_loc = expr.pexp_loc; + pexp_attributes = expr.pexp_attributes; + pexp_desc = + Pexp_field + ( mapper.expr mapper operand, + Location.mknoloc (Longident.Lident "contents") ); + } + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, + [ + (Asttypes.Nolabel, lhs); + ( Nolabel, + { + pexp_desc = + ( Pexp_constant (Pconst_string (txt, None)) + | Pexp_ident {txt = Longident.Lident txt} ); + pexp_loc = labelLoc; + } ); + ] ) -> + let label = Location.mkloc txt labelLoc in + { + pexp_loc = expr.pexp_loc; + pexp_attributes = expr.pexp_attributes; + pexp_desc = Pexp_send (mapper.expr mapper lhs, label); + } + | Pexp_match + ( condition, + [ + { + pc_lhs = + { + ppat_desc = + Ppat_construct ({txt = Longident.Lident "true"}, None); + }; + pc_rhs = thenExpr; + }; + { + pc_lhs = + { + ppat_desc = + Ppat_construct ({txt = Longident.Lident "false"}, None); + }; + pc_rhs = elseExpr; + }; + ] ) -> + let ternaryMarker = + (Location.mknoloc "ns.ternary", Parsetree.PStr []) + in + { + Parsetree.pexp_loc = expr.pexp_loc; + pexp_desc = + Pexp_ifthenelse + ( mapper.expr mapper condition, + mapper.expr mapper thenExpr, + Some (mapper.expr mapper elseExpr) ); + pexp_attributes = ternaryMarker :: expr.pexp_attributes; + } + | _ -> default_mapper.expr mapper expr); + structure_item = + (fun mapper structureItem -> + match structureItem.pstr_desc with + (* heuristic: if we have multiple type declarations, mark them recursive *) + | Pstr_type ((Recursive as recFlag), typeDeclarations) -> + let flag = + match typeDeclarations with + | [td] -> + if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive + else Asttypes.Nonrecursive + | _ -> recFlag + in + { + structureItem with + pstr_desc = + Pstr_type + ( flag, + List.map + (fun typeDeclaration -> + default_mapper.type_declaration mapper typeDeclaration) + typeDeclarations ); + } + | _ -> default_mapper.structure_item mapper structureItem); + signature_item = + (fun mapper signatureItem -> + match signatureItem.psig_desc with + (* heuristic: if we have multiple type declarations, mark them recursive *) + | Psig_type ((Recursive as recFlag), typeDeclarations) -> + let flag = + match typeDeclarations with + | [td] -> + if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive + else Asttypes.Nonrecursive + | _ -> recFlag + in + { + signatureItem with + psig_desc = + Psig_type + ( flag, + List.map + (fun typeDeclaration -> + default_mapper.type_declaration mapper typeDeclaration) + typeDeclarations ); + } + | _ -> default_mapper.signature_item mapper signatureItem); + value_binding = + (fun mapper vb -> + match vb with + | { + pvb_pat = {ppat_desc = Ppat_var _} as pat; + pvb_expr = + {pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ)}; } - | Pexp_match ( - condition, - [ - {pc_lhs = {ppat_desc = Ppat_construct ({txt = Longident.Lident "true"}, None)}; pc_rhs = thenExpr }; - {pc_lhs = {ppat_desc = Ppat_construct ({txt = Longident.Lident "false"}, None)}; pc_rhs = elseExpr }; - ] - ) -> - let ternaryMarker = (Location.mknoloc "ns.ternary", Parsetree.PStr []) in - {Parsetree.pexp_loc = expr.pexp_loc; - pexp_desc = Pexp_ifthenelse ( - mapper.expr mapper condition, - mapper.expr mapper thenExpr, - (Some (mapper.expr mapper elseExpr)) - ); - pexp_attributes = ternaryMarker::expr.pexp_attributes; + when expr_loc.loc_ghost -> + (* let t: t = (expr : t) -> let t: t = expr *) + let typ = default_mapper.typ mapper typ in + let pat = default_mapper.pat mapper pat in + let expr = mapper.expr mapper expr in + let newPattern = + { + Parsetree.ppat_loc = + {pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end}; + ppat_attributes = []; + ppat_desc = Ppat_constraint (pat, typ); + } + in + { + vb with + pvb_pat = newPattern; + pvb_expr = expr; + pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes; + } + | { + pvb_pat = + {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], _)})}; + pvb_expr = + {pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ)}; } - | _ -> default_mapper.expr mapper expr - ); - structure_item = begin fun mapper structureItem -> - match structureItem.pstr_desc with - (* heuristic: if we have multiple type declarations, mark them recursive *) - | Pstr_type (Recursive as recFlag, typeDeclarations) -> - let flag = match typeDeclarations with - | [td] -> - if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive - else Asttypes.Nonrecursive - | _ -> recFlag - in - {structureItem with pstr_desc = Pstr_type ( - flag, - List.map (fun typeDeclaration -> - default_mapper.type_declaration mapper typeDeclaration - ) typeDeclarations - )} - | _ -> default_mapper.structure_item mapper structureItem - end; - signature_item = begin fun mapper signatureItem -> - match signatureItem.psig_desc with - (* heuristic: if we have multiple type declarations, mark them recursive *) - | Psig_type (Recursive as recFlag, typeDeclarations) -> - let flag = match typeDeclarations with - | [td] -> - if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive - else Asttypes.Nonrecursive - | _ -> recFlag - in - {signatureItem with psig_desc = Psig_type ( - flag, - List.map (fun typeDeclaration -> - default_mapper.type_declaration mapper typeDeclaration - ) typeDeclarations - )} - | _ -> default_mapper.signature_item mapper signatureItem - end; - value_binding = begin fun mapper vb -> - match vb with - | { - pvb_pat = {ppat_desc = Ppat_var _} as pat; - pvb_expr = {pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ) } - } when expr_loc.loc_ghost -> - (* let t: t = (expr : t) -> let t: t = expr *) - let typ = default_mapper.typ mapper typ in - let pat = default_mapper.pat mapper pat in - let expr = mapper.expr mapper expr in - let newPattern = { - Parsetree.ppat_loc = {pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end}; - ppat_attributes = []; - ppat_desc = Ppat_constraint (pat, typ) - } in - {vb with - pvb_pat = newPattern; - pvb_expr = expr; - pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes} - | { - pvb_pat = {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], _)})} ; - pvb_expr = {pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ) } - } when expr_loc.loc_ghost -> - (* let t: . t = (expr : t) -> let t: t = expr *) - let typ = default_mapper.typ mapper typ in - let pat = default_mapper.pat mapper pat in - let expr = mapper.expr mapper expr in - let newPattern = { - Parsetree.ppat_loc = {pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end}; - ppat_attributes = []; - ppat_desc = Ppat_constraint (pat, typ) - } in - {vb with - pvb_pat = newPattern; - pvb_expr = expr; - pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes} - | _ -> default_mapper.value_binding mapper vb - end; + when expr_loc.loc_ghost -> + (* let t: . t = (expr : t) -> let t: t = expr *) + let typ = default_mapper.typ mapper typ in + let pat = default_mapper.pat mapper pat in + let expr = mapper.expr mapper expr in + let newPattern = + { + Parsetree.ppat_loc = + {pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end}; + ppat_attributes = []; + ppat_desc = Ppat_constraint (pat, typ); + } + in + { + vb with + pvb_pat = newPattern; + pvb_expr = expr; + pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes; + } + | _ -> default_mapper.value_binding mapper vb); } let normalizeReasonArityStructure ~forPrinter s = diff --git a/src/res_ast_conversion.mli b/src/res_ast_conversion.mli index f66f1965..8c868f44 100644 --- a/src/res_ast_conversion.mli +++ b/src/res_ast_conversion.mli @@ -7,18 +7,18 @@ * The purpose of this routine is to place the original string back in * the parsetree for printing purposes. Unicode and escape sequences * shouldn't be mangled when *) -val replaceStringLiteralStructure: +val replaceStringLiteralStructure : (string * Location.t) list -> Parsetree.structure -> Parsetree.structure -val replaceStringLiteralSignature: +val replaceStringLiteralSignature : (string * Location.t) list -> Parsetree.signature -> Parsetree.signature (* Get rid of the explicit/implicit arity attributes *) -val normalizeReasonArityStructure: +val normalizeReasonArityStructure : forPrinter:bool -> Parsetree.structure -> Parsetree.structure -val normalizeReasonAritySignature: +val normalizeReasonAritySignature : forPrinter:bool -> Parsetree.signature -> Parsetree.signature (* transform parts of the parsetree into a suitable parsetree suitable * for printing. Example: convert reason ternaries into rescript ternaries *) -val structure: Parsetree.structure -> Parsetree.structure -val signature: Parsetree.signature -> Parsetree.signature +val structure : Parsetree.structure -> Parsetree.structure +val signature : Parsetree.signature -> Parsetree.signature diff --git a/src/res_ast_debugger.ml b/src/res_ast_debugger.ml index 2c009c58..150ff78e 100644 --- a/src/res_ast_debugger.ml +++ b/src/res_ast_debugger.ml @@ -1,25 +1,25 @@ module Doc = Res_doc module CommentTable = Res_comments_table -let printEngine = Res_driver.{ - printImplementation = begin fun ~width:_ ~filename:_ ~comments:_ structure -> - Printast.implementation Format.std_formatter structure - end; - printInterface = begin fun ~width:_ ~filename:_ ~comments:_ signature -> - Printast.interface Format.std_formatter signature - end; -} - -module Sexp: sig +let printEngine = + Res_driver. + { + printImplementation = + (fun ~width:_ ~filename:_ ~comments:_ structure -> + Printast.implementation Format.std_formatter structure); + printInterface = + (fun ~width:_ ~filename:_ ~comments:_ signature -> + Printast.interface Format.std_formatter signature); + } + +module Sexp : sig type t - val atom: string -> t - val list: t list -> t - val toString: t -> string + val atom : string -> t + val list : t list -> t + val toString : t -> string end = struct - type t = - | Atom of string - | List of t list + type t = Atom of string | List of t list let atom s = Atom s let list l = List l @@ -28,21 +28,18 @@ end = struct match t with | Atom s -> Doc.text s | List [] -> Doc.text "()" - | List [sexpr] -> Doc.concat [Doc.lparen; toDoc sexpr; Doc.rparen;] - | List (hd::tail) -> - Doc.group ( - Doc.concat [ - Doc.lparen; - toDoc hd; - Doc.indent ( - Doc.concat [ - Doc.line; - Doc.join ~sep:Doc.line (List.map toDoc tail); - ] - ); - Doc.rparen; - ] - ) + | List [sexpr] -> Doc.concat [Doc.lparen; toDoc sexpr; Doc.rparen] + | List (hd :: tail) -> + Doc.group + (Doc.concat + [ + Doc.lparen; + toDoc hd; + Doc.indent + (Doc.concat + [Doc.line; Doc.join ~sep:Doc.line (List.map toDoc tail)]); + Doc.rparen; + ]) let toString sexpr = let doc = toDoc sexpr in @@ -57,1183 +54,882 @@ module SexpAst = struct | [] -> [Sexp.list []] | items -> List.map f items - let string txt = - Sexp.atom ("\"" ^ txt ^ "\"") + let string txt = Sexp.atom ("\"" ^ txt ^ "\"") - let char c = - Sexp.atom ("'" ^ (Char.escaped c) ^ "'") + let char c = Sexp.atom ("'" ^ Char.escaped c ^ "'") let optChar oc = match oc with | None -> Sexp.atom "None" - | Some c -> - Sexp.list [ - Sexp.atom "Some"; - char c - ] + | Some c -> Sexp.list [Sexp.atom "Some"; char c] let longident l = - let rec loop l = match l with - | Longident.Lident ident -> Sexp.list [ - Sexp.atom "Lident"; - string ident; - ] - | Longident.Ldot (lident, txt) -> - Sexp.list [ - Sexp.atom "Ldot"; - loop lident; - string txt; - ] - | Longident.Lapply (l1, l2) -> - Sexp.list [ - Sexp.atom "Lapply"; - loop l1; - loop l2; - ] + let rec loop l = + match l with + | Longident.Lident ident -> Sexp.list [Sexp.atom "Lident"; string ident] + | Longident.Ldot (lident, txt) -> + Sexp.list [Sexp.atom "Ldot"; loop lident; string txt] + | Longident.Lapply (l1, l2) -> + Sexp.list [Sexp.atom "Lapply"; loop l1; loop l2] in - Sexp.list [ - Sexp.atom "longident"; - loop l; - ] + Sexp.list [Sexp.atom "longident"; loop l] - let closedFlag flag = match flag with + let closedFlag flag = + match flag with | Asttypes.Closed -> Sexp.atom "Closed" | Open -> Sexp.atom "Open" - let directionFlag flag = match flag with + let directionFlag flag = + match flag with | Asttypes.Upto -> Sexp.atom "Upto" | Downto -> Sexp.atom "Downto" - let recFlag flag = match flag with + let recFlag flag = + match flag with | Asttypes.Recursive -> Sexp.atom "Recursive" | Nonrecursive -> Sexp.atom "Nonrecursive" - let overrideFlag flag = match flag with + let overrideFlag flag = + match flag with | Asttypes.Override -> Sexp.atom "Override" | Fresh -> Sexp.atom "Fresh" - let privateFlag flag = match flag with + let privateFlag flag = + match flag with | Asttypes.Public -> Sexp.atom "Public" | Private -> Sexp.atom "Private" - let mutableFlag flag = match flag with + let mutableFlag flag = + match flag with | Asttypes.Immutable -> Sexp.atom "Immutable" | Mutable -> Sexp.atom "Mutable" - let variance v = match v with - | Asttypes.Covariant -> Sexp.atom "Covariant" - | Contravariant -> Sexp.atom "Contravariant" - | Invariant -> Sexp.atom "Invariant" + let variance v = + match v with + | Asttypes.Covariant -> Sexp.atom "Covariant" + | Contravariant -> Sexp.atom "Contravariant" + | Invariant -> Sexp.atom "Invariant" - let argLabel lbl = match lbl with + let argLabel lbl = + match lbl with | Asttypes.Nolabel -> Sexp.atom "Nolabel" - | Labelled txt -> Sexp.list [ - Sexp.atom "Labelled"; - string txt; - ] - | Optional txt -> Sexp.list [ - Sexp.atom "Optional"; - string txt; - ] + | Labelled txt -> Sexp.list [Sexp.atom "Labelled"; string txt] + | Optional txt -> Sexp.list [Sexp.atom "Optional"; string txt] let constant c = - let sexpr = match c with - | Pconst_integer (txt, tag) -> - Sexp.list [ - Sexp.atom "Pconst_integer"; - string txt; - optChar tag; - ] - | Pconst_char _ -> - Sexp.list [ - Sexp.atom "Pconst_char"; - ] - | Pconst_string(_, Some "INTERNAL_RES_CHAR_CONTENTS") -> - Sexp.list [ - Sexp.atom "Pconst_char"; - ] - | Pconst_string (txt, tag) -> - Sexp.list [ - Sexp.atom "Pconst_string"; - string txt; - match tag with - | Some txt -> Sexp.list [ - Sexp.atom "Some"; + let sexpr = + match c with + | Pconst_integer (txt, tag) -> + Sexp.list [Sexp.atom "Pconst_integer"; string txt; optChar tag] + | Pconst_char _ -> Sexp.list [Sexp.atom "Pconst_char"] + | Pconst_string (_, Some "INTERNAL_RES_CHAR_CONTENTS") -> + Sexp.list [Sexp.atom "Pconst_char"] + | Pconst_string (txt, tag) -> + Sexp.list + [ + Sexp.atom "Pconst_string"; string txt; + (match tag with + | Some txt -> Sexp.list [Sexp.atom "Some"; string txt] + | None -> Sexp.atom "None"); ] - | None -> Sexp.atom "None"; - ] - | Pconst_float (txt, tag) -> - Sexp.list [ - Sexp.atom "Pconst_float"; - string txt; - optChar tag; - ] + | Pconst_float (txt, tag) -> + Sexp.list [Sexp.atom "Pconst_float"; string txt; optChar tag] in - Sexp.list [ - Sexp.atom "constant"; - sexpr - ] + Sexp.list [Sexp.atom "constant"; sexpr] let rec structure s = - Sexp.list ( - (Sexp.atom "structure")::(List.map structureItem s) - ) + Sexp.list (Sexp.atom "structure" :: List.map structureItem s) and structureItem si = - let desc = match si.pstr_desc with - | Pstr_eval (expr, attrs) -> - Sexp.list [ - Sexp.atom "Pstr_eval"; - expression expr; - attributes attrs; - ] - | Pstr_value (flag, vbs) -> - Sexp.list [ - Sexp.atom "Pstr_value"; - recFlag flag; - Sexp.list (mapEmpty ~f:valueBinding vbs) - ] - | Pstr_primitive (vd) -> - Sexp.list [ - Sexp.atom "Pstr_primitive"; - valueDescription vd; - ] - | Pstr_type (flag, tds) -> - Sexp.list [ - Sexp.atom "Pstr_type"; - recFlag flag; - Sexp.list (mapEmpty ~f:typeDeclaration tds) - ] - | Pstr_typext typext -> - Sexp.list [ - Sexp.atom "Pstr_type"; - typeExtension typext; - ] - | Pstr_exception ec -> - Sexp.list [ - Sexp.atom "Pstr_exception"; - extensionConstructor ec; - ] - | Pstr_module mb -> - Sexp.list [ - Sexp.atom "Pstr_module"; - moduleBinding mb; - ] - | Pstr_recmodule mbs -> - Sexp.list [ - Sexp.atom "Pstr_recmodule"; - Sexp.list (mapEmpty ~f:moduleBinding mbs); - ] - | Pstr_modtype modTypDecl -> - Sexp.list [ - Sexp.atom "Pstr_modtype"; - moduleTypeDeclaration modTypDecl; - ] - | Pstr_open openDesc -> - Sexp.list [ - Sexp.atom "Pstr_open"; - openDescription openDesc; - ] - | Pstr_class _ -> Sexp.atom "Pstr_class" - | Pstr_class_type _ -> Sexp.atom "Pstr_class_type" - | Pstr_include id -> - Sexp.list [ - Sexp.atom "Pstr_include"; - includeDeclaration id; - ] - | Pstr_attribute attr -> - Sexp.list [ - Sexp.atom "Pstr_attribute"; - attribute attr; - ] - | Pstr_extension (ext, attrs) -> - Sexp.list [ - Sexp.atom "Pstr_extension"; - extension ext; - attributes attrs; - ] + let desc = + match si.pstr_desc with + | Pstr_eval (expr, attrs) -> + Sexp.list [Sexp.atom "Pstr_eval"; expression expr; attributes attrs] + | Pstr_value (flag, vbs) -> + Sexp.list + [ + Sexp.atom "Pstr_value"; + recFlag flag; + Sexp.list (mapEmpty ~f:valueBinding vbs); + ] + | Pstr_primitive vd -> + Sexp.list [Sexp.atom "Pstr_primitive"; valueDescription vd] + | Pstr_type (flag, tds) -> + Sexp.list + [ + Sexp.atom "Pstr_type"; + recFlag flag; + Sexp.list (mapEmpty ~f:typeDeclaration tds); + ] + | Pstr_typext typext -> + Sexp.list [Sexp.atom "Pstr_type"; typeExtension typext] + | Pstr_exception ec -> + Sexp.list [Sexp.atom "Pstr_exception"; extensionConstructor ec] + | Pstr_module mb -> Sexp.list [Sexp.atom "Pstr_module"; moduleBinding mb] + | Pstr_recmodule mbs -> + Sexp.list + [ + Sexp.atom "Pstr_recmodule"; Sexp.list (mapEmpty ~f:moduleBinding mbs); + ] + | Pstr_modtype modTypDecl -> + Sexp.list [Sexp.atom "Pstr_modtype"; moduleTypeDeclaration modTypDecl] + | Pstr_open openDesc -> + Sexp.list [Sexp.atom "Pstr_open"; openDescription openDesc] + | Pstr_class _ -> Sexp.atom "Pstr_class" + | Pstr_class_type _ -> Sexp.atom "Pstr_class_type" + | Pstr_include id -> + Sexp.list [Sexp.atom "Pstr_include"; includeDeclaration id] + | Pstr_attribute attr -> + Sexp.list [Sexp.atom "Pstr_attribute"; attribute attr] + | Pstr_extension (ext, attrs) -> + Sexp.list [Sexp.atom "Pstr_extension"; extension ext; attributes attrs] in - Sexp.list [ - Sexp.atom "structure_item"; - desc; - ] + Sexp.list [Sexp.atom "structure_item"; desc] and includeDeclaration id = - Sexp.list [ - Sexp.atom "include_declaration"; - moduleExpression id.pincl_mod; - attributes id.pincl_attributes; - ] + Sexp.list + [ + Sexp.atom "include_declaration"; + moduleExpression id.pincl_mod; + attributes id.pincl_attributes; + ] and openDescription od = - Sexp.list [ - Sexp.atom "open_description"; - longident od.popen_lid.Asttypes.txt; - attributes od.popen_attributes; - ] + Sexp.list + [ + Sexp.atom "open_description"; + longident od.popen_lid.Asttypes.txt; + attributes od.popen_attributes; + ] and moduleTypeDeclaration mtd = - Sexp.list [ - Sexp.atom "module_type_declaration"; - string mtd.pmtd_name.Asttypes.txt; - (match mtd.pmtd_type with - | None -> Sexp.atom "None" - | Some modType -> Sexp.list [ - Sexp.atom "Some"; - moduleType modType; - ]); - attributes mtd.pmtd_attributes; - ] + Sexp.list + [ + Sexp.atom "module_type_declaration"; + string mtd.pmtd_name.Asttypes.txt; + (match mtd.pmtd_type with + | None -> Sexp.atom "None" + | Some modType -> Sexp.list [Sexp.atom "Some"; moduleType modType]); + attributes mtd.pmtd_attributes; + ] and moduleBinding mb = - Sexp.list [ - Sexp.atom "module_binding"; - string mb.pmb_name.Asttypes.txt; - moduleExpression mb.pmb_expr; - attributes mb.pmb_attributes; - ] + Sexp.list + [ + Sexp.atom "module_binding"; + string mb.pmb_name.Asttypes.txt; + moduleExpression mb.pmb_expr; + attributes mb.pmb_attributes; + ] and moduleExpression me = - let desc = match me.pmod_desc with - | Pmod_ident modName -> - Sexp.list [ - Sexp.atom "Pmod_ident"; - longident modName.Asttypes.txt; - ] - | Pmod_structure s -> - Sexp.list [ - Sexp.atom "Pmod_structure"; - structure s; - ] - | Pmod_functor (lbl, optModType, modExpr) -> - Sexp.list [ - Sexp.atom "Pmod_functor"; - string lbl.Asttypes.txt; - (match optModType with - | None -> Sexp.atom "None" - | Some modType -> Sexp.list [ - Sexp.atom "Some"; + let desc = + match me.pmod_desc with + | Pmod_ident modName -> + Sexp.list [Sexp.atom "Pmod_ident"; longident modName.Asttypes.txt] + | Pmod_structure s -> Sexp.list [Sexp.atom "Pmod_structure"; structure s] + | Pmod_functor (lbl, optModType, modExpr) -> + Sexp.list + [ + Sexp.atom "Pmod_functor"; + string lbl.Asttypes.txt; + (match optModType with + | None -> Sexp.atom "None" + | Some modType -> Sexp.list [Sexp.atom "Some"; moduleType modType]); + moduleExpression modExpr; + ] + | Pmod_apply (callModExpr, modExprArg) -> + Sexp.list + [ + Sexp.atom "Pmod_apply"; + moduleExpression callModExpr; + moduleExpression modExprArg; + ] + | Pmod_constraint (modExpr, modType) -> + Sexp.list + [ + Sexp.atom "Pmod_constraint"; + moduleExpression modExpr; moduleType modType; - ]); - moduleExpression modExpr; - ] - | Pmod_apply (callModExpr, modExprArg) -> - Sexp.list [ - Sexp.atom "Pmod_apply"; - moduleExpression callModExpr; - moduleExpression modExprArg; - ] - | Pmod_constraint (modExpr, modType) -> - Sexp.list [ - Sexp.atom "Pmod_constraint"; - moduleExpression modExpr; - moduleType modType; - ] - | Pmod_unpack expr -> - Sexp.list [ - Sexp.atom "Pmod_unpack"; - expression expr; - ] - | Pmod_extension ext -> - Sexp.list [ - Sexp.atom "Pmod_extension"; - extension ext; - ] + ] + | Pmod_unpack expr -> Sexp.list [Sexp.atom "Pmod_unpack"; expression expr] + | Pmod_extension ext -> + Sexp.list [Sexp.atom "Pmod_extension"; extension ext] in - Sexp.list [ - Sexp.atom "module_expr"; - desc; - attributes me.pmod_attributes; - ] + Sexp.list [Sexp.atom "module_expr"; desc; attributes me.pmod_attributes] and moduleType mt = - let desc = match mt.pmty_desc with - | Pmty_ident longidentLoc -> - Sexp.list [ - Sexp.atom "Pmty_ident"; - longident longidentLoc.Asttypes.txt; - ] - | Pmty_signature s -> - Sexp.list [ - Sexp.atom "Pmty_signature"; - signature s; - ] - | Pmty_functor (lbl, optModType, modType) -> - Sexp.list [ - Sexp.atom "Pmty_functor"; - string lbl.Asttypes.txt; - (match optModType with - | None -> Sexp.atom "None" - | Some modType -> Sexp.list [ - Sexp.atom "Some"; + let desc = + match mt.pmty_desc with + | Pmty_ident longidentLoc -> + Sexp.list [Sexp.atom "Pmty_ident"; longident longidentLoc.Asttypes.txt] + | Pmty_signature s -> Sexp.list [Sexp.atom "Pmty_signature"; signature s] + | Pmty_functor (lbl, optModType, modType) -> + Sexp.list + [ + Sexp.atom "Pmty_functor"; + string lbl.Asttypes.txt; + (match optModType with + | None -> Sexp.atom "None" + | Some modType -> Sexp.list [Sexp.atom "Some"; moduleType modType]); moduleType modType; - ]); - moduleType modType; - ] - | Pmty_alias longidentLoc -> - Sexp.list [ - Sexp.atom "Pmty_alias"; - longident longidentLoc.Asttypes.txt; - ] - | Pmty_extension ext -> - Sexp.list [ - Sexp.atom "Pmty_extension"; - extension ext; - ] - | Pmty_typeof modExpr -> - Sexp.list [ - Sexp.atom "Pmty_typeof"; - moduleExpression modExpr; - ] - | Pmty_with (modType, withConstraints) -> - Sexp.list [ - Sexp.atom "Pmty_with"; - moduleType modType; - Sexp.list (mapEmpty ~f:withConstraint withConstraints); - ] + ] + | Pmty_alias longidentLoc -> + Sexp.list [Sexp.atom "Pmty_alias"; longident longidentLoc.Asttypes.txt] + | Pmty_extension ext -> + Sexp.list [Sexp.atom "Pmty_extension"; extension ext] + | Pmty_typeof modExpr -> + Sexp.list [Sexp.atom "Pmty_typeof"; moduleExpression modExpr] + | Pmty_with (modType, withConstraints) -> + Sexp.list + [ + Sexp.atom "Pmty_with"; + moduleType modType; + Sexp.list (mapEmpty ~f:withConstraint withConstraints); + ] in - Sexp.list [ - Sexp.atom "module_type"; - desc; - attributes mt.pmty_attributes; - ] + Sexp.list [Sexp.atom "module_type"; desc; attributes mt.pmty_attributes] - and withConstraint wc = match wc with + and withConstraint wc = + match wc with | Pwith_type (longidentLoc, td) -> - Sexp.list [ - Sexp.atom "Pmty_with"; - longident longidentLoc.Asttypes.txt; - typeDeclaration td; - ] + Sexp.list + [ + Sexp.atom "Pmty_with"; + longident longidentLoc.Asttypes.txt; + typeDeclaration td; + ] | Pwith_module (l1, l2) -> - Sexp.list [ - Sexp.atom "Pwith_module"; - longident l1.Asttypes.txt; - longident l2.Asttypes.txt; - ] + Sexp.list + [ + Sexp.atom "Pwith_module"; + longident l1.Asttypes.txt; + longident l2.Asttypes.txt; + ] | Pwith_typesubst (longidentLoc, td) -> - Sexp.list [ - Sexp.atom "Pwith_typesubst"; - longident longidentLoc.Asttypes.txt; - typeDeclaration td; - ] + Sexp.list + [ + Sexp.atom "Pwith_typesubst"; + longident longidentLoc.Asttypes.txt; + typeDeclaration td; + ] | Pwith_modsubst (l1, l2) -> - Sexp.list [ - Sexp.atom "Pwith_modsubst"; - longident l1.Asttypes.txt; - longident l2.Asttypes.txt; - ] + Sexp.list + [ + Sexp.atom "Pwith_modsubst"; + longident l1.Asttypes.txt; + longident l2.Asttypes.txt; + ] - and signature s = - Sexp.list ( - (Sexp.atom "signature")::(List.map signatureItem s) - ) + and signature s = Sexp.list (Sexp.atom "signature" :: List.map signatureItem s) and signatureItem si = - let descr = match si.psig_desc with - | Psig_value vd -> - Sexp.list [ - Sexp.atom "Psig_value"; - valueDescription vd; - ] - | Psig_type (flag, typeDeclarations) -> - Sexp.list [ - Sexp.atom "Psig_type"; - recFlag flag; - Sexp.list (mapEmpty ~f:typeDeclaration typeDeclarations); - ] - | Psig_typext typExt -> - Sexp.list [ - Sexp.atom "Psig_typext"; - typeExtension typExt; - ] - | Psig_exception extConstr -> - Sexp.list [ - Sexp.atom "Psig_exception"; - extensionConstructor extConstr; - ] - | Psig_module modDecl -> - Sexp.list [ - Sexp.atom "Psig_module"; - moduleDeclaration modDecl; - ] - | Psig_recmodule modDecls -> - Sexp.list [ - Sexp.atom "Psig_recmodule"; - Sexp.list (mapEmpty ~f:moduleDeclaration modDecls); - ] - | Psig_modtype modTypDecl -> - Sexp.list [ - Sexp.atom "Psig_modtype"; - moduleTypeDeclaration modTypDecl; - ] - | Psig_open openDesc -> - Sexp.list [ - Sexp.atom "Psig_open"; - openDescription openDesc; - ] - | Psig_include inclDecl -> - Sexp.list [ - Sexp.atom "Psig_include"; - includeDescription inclDecl - ] - | Psig_class _ -> Sexp.list [Sexp.atom "Psig_class";] - | Psig_class_type _ -> Sexp.list [ Sexp.atom "Psig_class_type"; ] - | Psig_attribute attr -> - Sexp.list [ - Sexp.atom "Psig_attribute"; - attribute attr; - ] - | Psig_extension (ext, attrs) -> - Sexp.list [ - Sexp.atom "Psig_extension"; - extension ext; - attributes attrs; - ] + let descr = + match si.psig_desc with + | Psig_value vd -> Sexp.list [Sexp.atom "Psig_value"; valueDescription vd] + | Psig_type (flag, typeDeclarations) -> + Sexp.list + [ + Sexp.atom "Psig_type"; + recFlag flag; + Sexp.list (mapEmpty ~f:typeDeclaration typeDeclarations); + ] + | Psig_typext typExt -> + Sexp.list [Sexp.atom "Psig_typext"; typeExtension typExt] + | Psig_exception extConstr -> + Sexp.list [Sexp.atom "Psig_exception"; extensionConstructor extConstr] + | Psig_module modDecl -> + Sexp.list [Sexp.atom "Psig_module"; moduleDeclaration modDecl] + | Psig_recmodule modDecls -> + Sexp.list + [ + Sexp.atom "Psig_recmodule"; + Sexp.list (mapEmpty ~f:moduleDeclaration modDecls); + ] + | Psig_modtype modTypDecl -> + Sexp.list [Sexp.atom "Psig_modtype"; moduleTypeDeclaration modTypDecl] + | Psig_open openDesc -> + Sexp.list [Sexp.atom "Psig_open"; openDescription openDesc] + | Psig_include inclDecl -> + Sexp.list [Sexp.atom "Psig_include"; includeDescription inclDecl] + | Psig_class _ -> Sexp.list [Sexp.atom "Psig_class"] + | Psig_class_type _ -> Sexp.list [Sexp.atom "Psig_class_type"] + | Psig_attribute attr -> + Sexp.list [Sexp.atom "Psig_attribute"; attribute attr] + | Psig_extension (ext, attrs) -> + Sexp.list [Sexp.atom "Psig_extension"; extension ext; attributes attrs] in - Sexp.list [ - Sexp.atom "signature_item"; - descr; - ] + Sexp.list [Sexp.atom "signature_item"; descr] and includeDescription id = - Sexp.list [ - Sexp.atom "include_description"; - moduleType id.pincl_mod; - attributes id.pincl_attributes; - ] + Sexp.list + [ + Sexp.atom "include_description"; + moduleType id.pincl_mod; + attributes id.pincl_attributes; + ] and moduleDeclaration md = - Sexp.list [ - Sexp.atom "module_declaration"; - string md.pmd_name.Asttypes.txt; - moduleType md.pmd_type; - attributes md.pmd_attributes; - ] + Sexp.list + [ + Sexp.atom "module_declaration"; + string md.pmd_name.Asttypes.txt; + moduleType md.pmd_type; + attributes md.pmd_attributes; + ] and valueBinding vb = - Sexp.list [ - Sexp.atom "value_binding"; - pattern vb.pvb_pat; - expression vb.pvb_expr; - attributes vb.pvb_attributes; - ] + Sexp.list + [ + Sexp.atom "value_binding"; + pattern vb.pvb_pat; + expression vb.pvb_expr; + attributes vb.pvb_attributes; + ] and valueDescription vd = - Sexp.list [ - Sexp.atom "value_description"; - string vd.pval_name.Asttypes.txt; - coreType vd.pval_type; - Sexp.list (mapEmpty ~f:string vd.pval_prim); - attributes vd.pval_attributes; - ] + Sexp.list + [ + Sexp.atom "value_description"; + string vd.pval_name.Asttypes.txt; + coreType vd.pval_type; + Sexp.list (mapEmpty ~f:string vd.pval_prim); + attributes vd.pval_attributes; + ] and typeDeclaration td = - Sexp.list [ - Sexp.atom "type_declaration"; - string td.ptype_name.Asttypes.txt; - Sexp.list [ - Sexp.atom "ptype_params"; - Sexp.list (mapEmpty ~f:(fun (typexpr, var) -> - Sexp.list [ - coreType typexpr; - variance var; - ]) td.ptype_params) - ]; - Sexp.list [ - Sexp.atom "ptype_cstrs"; - Sexp.list (mapEmpty ~f:(fun (typ1, typ2, _loc) -> - Sexp.list [ - coreType typ1; - coreType typ2; - ]) td.ptype_cstrs) - ]; - Sexp.list [ - Sexp.atom "ptype_kind"; - typeKind td.ptype_kind; - ]; - Sexp.list [ - Sexp.atom "ptype_manifest"; - match td.ptype_manifest with - | None -> Sexp.atom "None" - | Some typ -> Sexp.list [ - Sexp.atom "Some"; - coreType typ; - ] - ]; - Sexp.list [ - Sexp.atom "ptype_private"; - privateFlag td.ptype_private; - ]; - attributes td.ptype_attributes; - ] + Sexp.list + [ + Sexp.atom "type_declaration"; + string td.ptype_name.Asttypes.txt; + Sexp.list + [ + Sexp.atom "ptype_params"; + Sexp.list + (mapEmpty + ~f:(fun (typexpr, var) -> + Sexp.list [coreType typexpr; variance var]) + td.ptype_params); + ]; + Sexp.list + [ + Sexp.atom "ptype_cstrs"; + Sexp.list + (mapEmpty + ~f:(fun (typ1, typ2, _loc) -> + Sexp.list [coreType typ1; coreType typ2]) + td.ptype_cstrs); + ]; + Sexp.list [Sexp.atom "ptype_kind"; typeKind td.ptype_kind]; + Sexp.list + [ + Sexp.atom "ptype_manifest"; + (match td.ptype_manifest with + | None -> Sexp.atom "None" + | Some typ -> Sexp.list [Sexp.atom "Some"; coreType typ]); + ]; + Sexp.list [Sexp.atom "ptype_private"; privateFlag td.ptype_private]; + attributes td.ptype_attributes; + ] and extensionConstructor ec = - Sexp.list [ - Sexp.atom "extension_constructor"; - string ec.pext_name.Asttypes.txt; - extensionConstructorKind ec.pext_kind; - attributes ec.pext_attributes; - ] + Sexp.list + [ + Sexp.atom "extension_constructor"; + string ec.pext_name.Asttypes.txt; + extensionConstructorKind ec.pext_kind; + attributes ec.pext_attributes; + ] - and extensionConstructorKind kind = match kind with + and extensionConstructorKind kind = + match kind with | Pext_decl (args, optTypExpr) -> - Sexp.list [ - Sexp.atom "Pext_decl"; - constructorArguments args; - match optTypExpr with - | None -> Sexp.atom "None" - | Some typ -> Sexp.list [ - Sexp.atom "Some"; - coreType typ; - ] - ] - | Pext_rebind longidentLoc -> - Sexp.list [ - Sexp.atom "Pext_rebind"; - longident longidentLoc.Asttypes.txt; - ] + Sexp.list + [ + Sexp.atom "Pext_decl"; + constructorArguments args; + (match optTypExpr with + | None -> Sexp.atom "None" + | Some typ -> Sexp.list [Sexp.atom "Some"; coreType typ]); + ] + | Pext_rebind longidentLoc -> + Sexp.list [Sexp.atom "Pext_rebind"; longident longidentLoc.Asttypes.txt] and typeExtension te = - Sexp.list [ - Sexp.atom "type_extension"; - Sexp.list [ - Sexp.atom "ptyext_path"; - longident te.ptyext_path.Asttypes.txt; - ]; - Sexp.list [ - Sexp.atom "ptyext_parms"; - Sexp.list (mapEmpty ~f:(fun (typexpr, var) -> - Sexp.list [ - coreType typexpr; - variance var; - ]) te.ptyext_params) - ]; - Sexp.list [ - Sexp.atom "ptyext_constructors"; - Sexp.list (mapEmpty ~f:extensionConstructor te.ptyext_constructors); - ]; - Sexp.list [ - Sexp.atom "ptyext_private"; - privateFlag te.ptyext_private; - ]; - attributes te.ptyext_attributes; - ] - - and typeKind kind = match kind with + Sexp.list + [ + Sexp.atom "type_extension"; + Sexp.list + [Sexp.atom "ptyext_path"; longident te.ptyext_path.Asttypes.txt]; + Sexp.list + [ + Sexp.atom "ptyext_parms"; + Sexp.list + (mapEmpty + ~f:(fun (typexpr, var) -> + Sexp.list [coreType typexpr; variance var]) + te.ptyext_params); + ]; + Sexp.list + [ + Sexp.atom "ptyext_constructors"; + Sexp.list (mapEmpty ~f:extensionConstructor te.ptyext_constructors); + ]; + Sexp.list [Sexp.atom "ptyext_private"; privateFlag te.ptyext_private]; + attributes te.ptyext_attributes; + ] + + and typeKind kind = + match kind with | Ptype_abstract -> Sexp.atom "Ptype_abstract" | Ptype_variant constrDecls -> - Sexp.list [ - Sexp.atom "Ptype_variant"; - Sexp.list (mapEmpty ~f:constructorDeclaration constrDecls); - ] + Sexp.list + [ + Sexp.atom "Ptype_variant"; + Sexp.list (mapEmpty ~f:constructorDeclaration constrDecls); + ] | Ptype_record lblDecls -> - Sexp.list [ - Sexp.atom "Ptype_record"; - Sexp.list (mapEmpty ~f:labelDeclaration lblDecls); - ] + Sexp.list + [ + Sexp.atom "Ptype_record"; + Sexp.list (mapEmpty ~f:labelDeclaration lblDecls); + ] | Ptype_open -> Sexp.atom "Ptype_open" and constructorDeclaration cd = - Sexp.list [ - Sexp.atom "constructor_declaration"; - string cd.pcd_name.Asttypes.txt; - Sexp.list [ - Sexp.atom "pcd_args"; - constructorArguments cd.pcd_args; - ]; - Sexp.list [ - Sexp.atom "pcd_res"; - match cd.pcd_res with - | None -> Sexp.atom "None" - | Some typ -> Sexp.list [ - Sexp.atom "Some"; - coreType typ; - ] - ]; - attributes cd.pcd_attributes; - ] - - and constructorArguments args = match args with + Sexp.list + [ + Sexp.atom "constructor_declaration"; + string cd.pcd_name.Asttypes.txt; + Sexp.list [Sexp.atom "pcd_args"; constructorArguments cd.pcd_args]; + Sexp.list + [ + Sexp.atom "pcd_res"; + (match cd.pcd_res with + | None -> Sexp.atom "None" + | Some typ -> Sexp.list [Sexp.atom "Some"; coreType typ]); + ]; + attributes cd.pcd_attributes; + ] + + and constructorArguments args = + match args with | Pcstr_tuple types -> - Sexp.list [ - Sexp.atom "Pcstr_tuple"; - Sexp.list (mapEmpty ~f:coreType types) - ] + Sexp.list + [Sexp.atom "Pcstr_tuple"; Sexp.list (mapEmpty ~f:coreType types)] | Pcstr_record lds -> - Sexp.list [ - Sexp.atom "Pcstr_record"; - Sexp.list (mapEmpty ~f:labelDeclaration lds) - ] + Sexp.list + [Sexp.atom "Pcstr_record"; Sexp.list (mapEmpty ~f:labelDeclaration lds)] and labelDeclaration ld = - Sexp.list [ - Sexp.atom "label_declaration"; - string ld.pld_name.Asttypes.txt; - mutableFlag ld.pld_mutable; - coreType ld.pld_type; - attributes ld.pld_attributes; - ] + Sexp.list + [ + Sexp.atom "label_declaration"; + string ld.pld_name.Asttypes.txt; + mutableFlag ld.pld_mutable; + coreType ld.pld_type; + attributes ld.pld_attributes; + ] and expression expr = - let desc = match expr.pexp_desc with - | Pexp_ident longidentLoc -> - Sexp.list [ - Sexp.atom "Pexp_ident"; - longident longidentLoc.Asttypes.txt; - ] - | Pexp_constant c -> - Sexp.list [ - Sexp.atom "Pexp_constant"; - constant c - ] - | Pexp_let (flag, vbs, expr) -> - Sexp.list [ - Sexp.atom "Pexp_let"; - recFlag flag; - Sexp.list (mapEmpty ~f:valueBinding vbs); - expression expr; - ] - | Pexp_function cases -> - Sexp.list [ - Sexp.atom "Pexp_function"; - Sexp.list (mapEmpty ~f:case cases); - ] - | Pexp_fun (argLbl, exprOpt, pat, expr) -> - Sexp.list [ - Sexp.atom "Pexp_fun"; - argLabel argLbl; - (match exprOpt with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [ - Sexp.atom "Some"; + let desc = + match expr.pexp_desc with + | Pexp_ident longidentLoc -> + Sexp.list [Sexp.atom "Pexp_ident"; longident longidentLoc.Asttypes.txt] + | Pexp_constant c -> Sexp.list [Sexp.atom "Pexp_constant"; constant c] + | Pexp_let (flag, vbs, expr) -> + Sexp.list + [ + Sexp.atom "Pexp_let"; + recFlag flag; + Sexp.list (mapEmpty ~f:valueBinding vbs); expression expr; - ]); - pattern pat; - expression expr; - ] - | Pexp_apply (expr, args) -> - Sexp.list [ - Sexp.atom "Pexp_apply"; - expression expr; - Sexp.list (mapEmpty ~f:(fun (argLbl, expr) -> Sexp.list [ - argLabel argLbl; - expression expr - ]) args); - ] - | Pexp_match (expr, cases) -> - Sexp.list [ - Sexp.atom "Pexp_match"; - expression expr; - Sexp.list (mapEmpty ~f:case cases); - ] - | Pexp_try (expr, cases) -> - Sexp.list [ - Sexp.atom "Pexp_try"; - expression expr; - Sexp.list (mapEmpty ~f:case cases); - ] - | Pexp_tuple exprs -> - Sexp.list [ - Sexp.atom "Pexp_tuple"; - Sexp.list (mapEmpty ~f:expression exprs); - ] - | Pexp_construct (longidentLoc, exprOpt) -> - Sexp.list [ - Sexp.atom "Pexp_construct"; - longident longidentLoc.Asttypes.txt; - match exprOpt with - | None -> Sexp.atom "None" - | Some expr -> - Sexp.list [ - Sexp.atom "Some"; + ] + | Pexp_function cases -> + Sexp.list + [Sexp.atom "Pexp_function"; Sexp.list (mapEmpty ~f:case cases)] + | Pexp_fun (argLbl, exprOpt, pat, expr) -> + Sexp.list + [ + Sexp.atom "Pexp_fun"; + argLabel argLbl; + (match exprOpt with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); + pattern pat; expression expr; ] - ] - | Pexp_variant (lbl, exprOpt) -> - Sexp.list [ - Sexp.atom "Pexp_variant"; - string lbl; - match exprOpt with - | None -> Sexp.atom "None" - | Some expr -> - Sexp.list [ - Sexp.atom "Some"; + | Pexp_apply (expr, args) -> + Sexp.list + [ + Sexp.atom "Pexp_apply"; expression expr; + Sexp.list + (mapEmpty + ~f:(fun (argLbl, expr) -> + Sexp.list [argLabel argLbl; expression expr]) + args); ] - ] - | Pexp_record (rows, optExpr) -> - Sexp.list [ - Sexp.atom "Pexp_record"; - Sexp.list (mapEmpty ~f:(fun (longidentLoc, expr) -> Sexp.list [ - longident longidentLoc.Asttypes.txt; - expression expr; - ]) rows); - (match optExpr with - | None -> Sexp.atom "None" - | Some expr -> - Sexp.list [ - Sexp.atom "Some"; + | Pexp_match (expr, cases) -> + Sexp.list + [ + Sexp.atom "Pexp_match"; expression expr; - ]); - ] - | Pexp_field (expr, longidentLoc) -> - Sexp.list [ - Sexp.atom "Pexp_field"; - expression expr; - longident longidentLoc.Asttypes.txt; - ] - | Pexp_setfield (expr1, longidentLoc, expr2) -> - Sexp.list [ - Sexp.atom "Pexp_setfield"; - expression expr1; - longident longidentLoc.Asttypes.txt; - expression expr2; - ] - | Pexp_array exprs -> - Sexp.list [ - Sexp.atom "Pexp_array"; - Sexp.list (mapEmpty ~f:expression exprs); - ] - | Pexp_ifthenelse (expr1, expr2, optExpr) -> - Sexp.list [ - Sexp.atom "Pexp_ifthenelse"; - expression expr1; - expression expr2; - (match optExpr with - | None -> Sexp.atom "None" - | Some expr -> - Sexp.list [ - Sexp.atom "Some"; + Sexp.list (mapEmpty ~f:case cases); + ] + | Pexp_try (expr, cases) -> + Sexp.list + [ + Sexp.atom "Pexp_try"; expression expr; - ]); - ] - | Pexp_sequence (expr1, expr2) -> - Sexp.list [ - Sexp.atom "Pexp_sequence"; - expression expr1; - expression expr2; - ] - | Pexp_while (expr1, expr2) -> - Sexp.list [ - Sexp.atom "Pexp_while"; - expression expr1; - expression expr2; - ] - | Pexp_for (pat, e1, e2, flag, e3) -> - Sexp.list [ - Sexp.atom "Pexp_for"; - pattern pat; - expression e1; - expression e2; - directionFlag flag; - expression e3; - ] - | Pexp_constraint (expr, typexpr) -> - Sexp.list [ - Sexp.atom "Pexp_constraint"; - expression expr; - coreType typexpr; - ] - | Pexp_coerce (expr, optTyp, typexpr) -> - Sexp.list [ - Sexp.atom "Pexp_coerce"; - expression expr; - (match optTyp with - | None -> Sexp.atom "None" - | Some typ -> Sexp.list [ - Sexp.atom "Some"; - coreType typ; - ]); - coreType typexpr; - ] - | Pexp_send _ -> - Sexp.list [ - Sexp.atom "Pexp_send"; - ] - | Pexp_new _ -> - Sexp.list [ - Sexp.atom "Pexp_new"; - ] - | Pexp_setinstvar _ -> - Sexp.list [ - Sexp.atom "Pexp_setinstvar"; - ] - | Pexp_override _ -> - Sexp.list [ - Sexp.atom "Pexp_override"; - ] - | Pexp_letmodule (modName, modExpr, expr) -> - Sexp.list [ - Sexp.atom "Pexp_letmodule"; - string modName.Asttypes.txt; - moduleExpression modExpr; - expression expr; - ] - | Pexp_letexception (extConstr, expr) -> - Sexp.list [ - Sexp.atom "Pexp_letexception"; - extensionConstructor extConstr; - expression expr; - ] - | Pexp_assert expr -> - Sexp.list [ - Sexp.atom "Pexp_assert"; - expression expr; - ] - | Pexp_lazy expr -> - Sexp.list [ - Sexp.atom "Pexp_lazy"; - expression expr; - ] - | Pexp_poly _ -> - Sexp.list [ - Sexp.atom "Pexp_poly"; - ] - | Pexp_object _ -> - Sexp.list [ - Sexp.atom "Pexp_object"; - ] - | Pexp_newtype (lbl, expr) -> - Sexp.list [ - Sexp.atom "Pexp_newtype"; - string lbl.Asttypes.txt; - expression expr; - ] - | Pexp_pack modExpr -> - Sexp.list [ - Sexp.atom "Pexp_pack"; - moduleExpression modExpr; - ] - | Pexp_open (flag, longidentLoc, expr) -> - Sexp.list [ - Sexp.atom "Pexp_open"; - overrideFlag flag; - longident longidentLoc.Asttypes.txt; - expression expr; - ] - | Pexp_extension ext -> - Sexp.list [ - Sexp.atom "Pexp_extension"; - extension ext; - ] - | Pexp_unreachable -> Sexp.atom "Pexp_unreachable" + Sexp.list (mapEmpty ~f:case cases); + ] + | Pexp_tuple exprs -> + Sexp.list + [Sexp.atom "Pexp_tuple"; Sexp.list (mapEmpty ~f:expression exprs)] + | Pexp_construct (longidentLoc, exprOpt) -> + Sexp.list + [ + Sexp.atom "Pexp_construct"; + longident longidentLoc.Asttypes.txt; + (match exprOpt with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); + ] + | Pexp_variant (lbl, exprOpt) -> + Sexp.list + [ + Sexp.atom "Pexp_variant"; + string lbl; + (match exprOpt with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); + ] + | Pexp_record (rows, optExpr) -> + Sexp.list + [ + Sexp.atom "Pexp_record"; + Sexp.list + (mapEmpty + ~f:(fun (longidentLoc, expr) -> + Sexp.list + [longident longidentLoc.Asttypes.txt; expression expr]) + rows); + (match optExpr with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); + ] + | Pexp_field (expr, longidentLoc) -> + Sexp.list + [ + Sexp.atom "Pexp_field"; + expression expr; + longident longidentLoc.Asttypes.txt; + ] + | Pexp_setfield (expr1, longidentLoc, expr2) -> + Sexp.list + [ + Sexp.atom "Pexp_setfield"; + expression expr1; + longident longidentLoc.Asttypes.txt; + expression expr2; + ] + | Pexp_array exprs -> + Sexp.list + [Sexp.atom "Pexp_array"; Sexp.list (mapEmpty ~f:expression exprs)] + | Pexp_ifthenelse (expr1, expr2, optExpr) -> + Sexp.list + [ + Sexp.atom "Pexp_ifthenelse"; + expression expr1; + expression expr2; + (match optExpr with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); + ] + | Pexp_sequence (expr1, expr2) -> + Sexp.list + [Sexp.atom "Pexp_sequence"; expression expr1; expression expr2] + | Pexp_while (expr1, expr2) -> + Sexp.list [Sexp.atom "Pexp_while"; expression expr1; expression expr2] + | Pexp_for (pat, e1, e2, flag, e3) -> + Sexp.list + [ + Sexp.atom "Pexp_for"; + pattern pat; + expression e1; + expression e2; + directionFlag flag; + expression e3; + ] + | Pexp_constraint (expr, typexpr) -> + Sexp.list + [Sexp.atom "Pexp_constraint"; expression expr; coreType typexpr] + | Pexp_coerce (expr, optTyp, typexpr) -> + Sexp.list + [ + Sexp.atom "Pexp_coerce"; + expression expr; + (match optTyp with + | None -> Sexp.atom "None" + | Some typ -> Sexp.list [Sexp.atom "Some"; coreType typ]); + coreType typexpr; + ] + | Pexp_send _ -> Sexp.list [Sexp.atom "Pexp_send"] + | Pexp_new _ -> Sexp.list [Sexp.atom "Pexp_new"] + | Pexp_setinstvar _ -> Sexp.list [Sexp.atom "Pexp_setinstvar"] + | Pexp_override _ -> Sexp.list [Sexp.atom "Pexp_override"] + | Pexp_letmodule (modName, modExpr, expr) -> + Sexp.list + [ + Sexp.atom "Pexp_letmodule"; + string modName.Asttypes.txt; + moduleExpression modExpr; + expression expr; + ] + | Pexp_letexception (extConstr, expr) -> + Sexp.list + [ + Sexp.atom "Pexp_letexception"; + extensionConstructor extConstr; + expression expr; + ] + | Pexp_assert expr -> Sexp.list [Sexp.atom "Pexp_assert"; expression expr] + | Pexp_lazy expr -> Sexp.list [Sexp.atom "Pexp_lazy"; expression expr] + | Pexp_poly _ -> Sexp.list [Sexp.atom "Pexp_poly"] + | Pexp_object _ -> Sexp.list [Sexp.atom "Pexp_object"] + | Pexp_newtype (lbl, expr) -> + Sexp.list + [Sexp.atom "Pexp_newtype"; string lbl.Asttypes.txt; expression expr] + | Pexp_pack modExpr -> + Sexp.list [Sexp.atom "Pexp_pack"; moduleExpression modExpr] + | Pexp_open (flag, longidentLoc, expr) -> + Sexp.list + [ + Sexp.atom "Pexp_open"; + overrideFlag flag; + longident longidentLoc.Asttypes.txt; + expression expr; + ] + | Pexp_extension ext -> + Sexp.list [Sexp.atom "Pexp_extension"; extension ext] + | Pexp_unreachable -> Sexp.atom "Pexp_unreachable" in - Sexp.list [ - Sexp.atom "expression"; - desc; - ] + Sexp.list [Sexp.atom "expression"; desc] and case c = - Sexp.list [ - Sexp.atom "case"; - Sexp.list [ - Sexp.atom "pc_lhs"; - pattern c.pc_lhs; - ]; - Sexp.list [ - Sexp.atom "pc_guard"; - match c.pc_guard with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [ - Sexp.atom "Some"; - expression expr; - ] - ]; - Sexp.list [ - Sexp.atom "pc_rhs"; - expression c.pc_rhs; + Sexp.list + [ + Sexp.atom "case"; + Sexp.list [Sexp.atom "pc_lhs"; pattern c.pc_lhs]; + Sexp.list + [ + Sexp.atom "pc_guard"; + (match c.pc_guard with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); + ]; + Sexp.list [Sexp.atom "pc_rhs"; expression c.pc_rhs]; ] - ] and pattern p = - let descr = match p.ppat_desc with - | Ppat_any -> - Sexp.atom "Ppat_any" - | Ppat_var var -> - Sexp.list [ - Sexp.atom "Ppat_var"; - string var.Location.txt; - ] - | Ppat_alias (p, alias) -> - Sexp.list [ - Sexp.atom "Ppat_alias"; - pattern p; - string alias.txt; - ] - | Ppat_constant c -> - Sexp.list [ - Sexp.atom "Ppat_constant"; - constant c; - ] - | Ppat_interval (lo, hi) -> - Sexp.list [ - Sexp.atom "Ppat_interval"; - constant lo; - constant hi; - ] - | Ppat_tuple (patterns) -> - Sexp.list [ - Sexp.atom "Ppat_tuple"; - Sexp.list (mapEmpty ~f:pattern patterns); - ] - | Ppat_construct (longidentLoc, optPattern) -> - Sexp.list [ - Sexp.atom "Ppat_construct"; - longident longidentLoc.Location.txt; - match optPattern with - | None -> Sexp.atom "None" - | Some p -> Sexp.list [ - Sexp.atom "some"; - pattern p; + let descr = + match p.ppat_desc with + | Ppat_any -> Sexp.atom "Ppat_any" + | Ppat_var var -> + Sexp.list [Sexp.atom "Ppat_var"; string var.Location.txt] + | Ppat_alias (p, alias) -> + Sexp.list [Sexp.atom "Ppat_alias"; pattern p; string alias.txt] + | Ppat_constant c -> Sexp.list [Sexp.atom "Ppat_constant"; constant c] + | Ppat_interval (lo, hi) -> + Sexp.list [Sexp.atom "Ppat_interval"; constant lo; constant hi] + | Ppat_tuple patterns -> + Sexp.list + [Sexp.atom "Ppat_tuple"; Sexp.list (mapEmpty ~f:pattern patterns)] + | Ppat_construct (longidentLoc, optPattern) -> + Sexp.list + [ + Sexp.atom "Ppat_construct"; + longident longidentLoc.Location.txt; + (match optPattern with + | None -> Sexp.atom "None" + | Some p -> Sexp.list [Sexp.atom "some"; pattern p]); ] - ] - | Ppat_variant (lbl, optPattern) -> - Sexp.list [ - Sexp.atom "Ppat_variant"; - string lbl; - match optPattern with - | None -> Sexp.atom "None" - | Some p -> Sexp.list [ - Sexp.atom "Some"; - pattern p; + | Ppat_variant (lbl, optPattern) -> + Sexp.list + [ + Sexp.atom "Ppat_variant"; + string lbl; + (match optPattern with + | None -> Sexp.atom "None" + | Some p -> Sexp.list [Sexp.atom "Some"; pattern p]); ] - ] - | Ppat_record (rows, flag) -> - Sexp.list [ - Sexp.atom "Ppat_record"; - closedFlag flag; - Sexp.list (mapEmpty ~f:(fun (longidentLoc, p) -> - Sexp.list [ - longident longidentLoc.Location.txt; - pattern p; + | Ppat_record (rows, flag) -> + Sexp.list + [ + Sexp.atom "Ppat_record"; + closedFlag flag; + Sexp.list + (mapEmpty + ~f:(fun (longidentLoc, p) -> + Sexp.list [longident longidentLoc.Location.txt; pattern p]) + rows); + ] + | Ppat_array patterns -> + Sexp.list + [Sexp.atom "Ppat_array"; Sexp.list (mapEmpty ~f:pattern patterns)] + | Ppat_or (p1, p2) -> + Sexp.list [Sexp.atom "Ppat_or"; pattern p1; pattern p2] + | Ppat_constraint (p, typexpr) -> + Sexp.list [Sexp.atom "Ppat_constraint"; pattern p; coreType typexpr] + | Ppat_type longidentLoc -> + Sexp.list [Sexp.atom "Ppat_type"; longident longidentLoc.Location.txt] + | Ppat_lazy p -> Sexp.list [Sexp.atom "Ppat_lazy"; pattern p] + | Ppat_unpack stringLoc -> + Sexp.list [Sexp.atom "Ppat_unpack"; string stringLoc.Location.txt] + | Ppat_exception p -> Sexp.list [Sexp.atom "Ppat_exception"; pattern p] + | Ppat_extension ext -> + Sexp.list [Sexp.atom "Ppat_extension"; extension ext] + | Ppat_open (longidentLoc, p) -> + Sexp.list + [ + Sexp.atom "Ppat_open"; longident longidentLoc.Location.txt; pattern p; ] - ) rows) - ] - | Ppat_array patterns -> - Sexp.list [ - Sexp.atom "Ppat_array"; - Sexp.list (mapEmpty ~f:pattern patterns); - ] - | Ppat_or (p1, p2) -> - Sexp.list [ - Sexp.atom "Ppat_or"; - pattern p1; - pattern p2; - ] - | Ppat_constraint (p, typexpr) -> - Sexp.list [ - Sexp.atom "Ppat_constraint"; - pattern p; - coreType typexpr; - ] - | Ppat_type longidentLoc -> - Sexp.list [ - Sexp.atom "Ppat_type"; - longident longidentLoc.Location.txt - ] - | Ppat_lazy p -> - Sexp.list [ - Sexp.atom "Ppat_lazy"; - pattern p; - ] - | Ppat_unpack stringLoc -> - Sexp.list [ - Sexp.atom "Ppat_unpack"; - string stringLoc.Location.txt; - ] - | Ppat_exception p -> - Sexp.list [ - Sexp.atom "Ppat_exception"; - pattern p; - ] - | Ppat_extension ext -> - Sexp.list [ - Sexp.atom "Ppat_extension"; - extension ext; - ] - | Ppat_open (longidentLoc, p) -> - Sexp.list [ - Sexp.atom "Ppat_open"; - longident longidentLoc.Location.txt; - pattern p; - ] in - Sexp.list [ - Sexp.atom "pattern"; - descr; - ] - - and objectField field = match field with - | Otag (lblLoc, attrs, typexpr) -> - Sexp.list [ - Sexp.atom "Otag"; - string lblLoc.txt; - attributes attrs; - coreType typexpr; - ] - | Oinherit typexpr -> - Sexp.list [ - Sexp.atom "Oinherit"; - coreType typexpr; - ] + Sexp.list [Sexp.atom "pattern"; descr] + + and objectField field = + match field with + | Otag (lblLoc, attrs, typexpr) -> + Sexp.list + [ + Sexp.atom "Otag"; string lblLoc.txt; attributes attrs; coreType typexpr; + ] + | Oinherit typexpr -> Sexp.list [Sexp.atom "Oinherit"; coreType typexpr] - and rowField field = match field with + and rowField field = + match field with | Rtag (labelLoc, attrs, truth, types) -> - Sexp.list [ - Sexp.atom "Rtag"; - string labelLoc.txt; - attributes attrs; - Sexp.atom (if truth then "true" else "false"); - Sexp.list (mapEmpty ~f:coreType types); - ] - | Rinherit typexpr -> - Sexp.list [ - Sexp.atom "Rinherit"; - coreType typexpr; - ] + Sexp.list + [ + Sexp.atom "Rtag"; + string labelLoc.txt; + attributes attrs; + Sexp.atom (if truth then "true" else "false"); + Sexp.list (mapEmpty ~f:coreType types); + ] + | Rinherit typexpr -> Sexp.list [Sexp.atom "Rinherit"; coreType typexpr] and packageType (modNameLoc, packageConstraints) = - Sexp.list [ - Sexp.atom "package_type"; - longident modNameLoc.Asttypes.txt; - Sexp.list (mapEmpty ~f:(fun (modNameLoc, typexpr) -> - Sexp.list [ - longident modNameLoc.Asttypes.txt; - coreType typexpr; - ] - ) packageConstraints) - ] + Sexp.list + [ + Sexp.atom "package_type"; + longident modNameLoc.Asttypes.txt; + Sexp.list + (mapEmpty + ~f:(fun (modNameLoc, typexpr) -> + Sexp.list [longident modNameLoc.Asttypes.txt; coreType typexpr]) + packageConstraints); + ] and coreType typexpr = - let desc = match typexpr.ptyp_desc with + let desc = + match typexpr.ptyp_desc with | Ptyp_any -> Sexp.atom "Ptyp_any" - | Ptyp_var var -> Sexp.list [ - Sexp.atom "Ptyp_var"; - string var - ] + | Ptyp_var var -> Sexp.list [Sexp.atom "Ptyp_var"; string var] | Ptyp_arrow (argLbl, typ1, typ2) -> - Sexp.list [ - Sexp.atom "Ptyp_arrow"; - argLabel argLbl; - coreType typ1; - coreType typ2; - ] + Sexp.list + [ + Sexp.atom "Ptyp_arrow"; argLabel argLbl; coreType typ1; coreType typ2; + ] | Ptyp_tuple types -> - Sexp.list [ - Sexp.atom "Ptyp_tuple"; - Sexp.list (mapEmpty ~f:coreType types); - ] + Sexp.list + [Sexp.atom "Ptyp_tuple"; Sexp.list (mapEmpty ~f:coreType types)] | Ptyp_constr (longidentLoc, types) -> - Sexp.list [ - Sexp.atom "Ptyp_constr"; - longident longidentLoc.txt; - Sexp.list (mapEmpty ~f:coreType types); - ] + Sexp.list + [ + Sexp.atom "Ptyp_constr"; + longident longidentLoc.txt; + Sexp.list (mapEmpty ~f:coreType types); + ] | Ptyp_alias (typexpr, alias) -> - Sexp.list [ - Sexp.atom "Ptyp_alias"; - coreType typexpr; - string alias; - ] + Sexp.list [Sexp.atom "Ptyp_alias"; coreType typexpr; string alias] | Ptyp_object (fields, flag) -> - Sexp.list [ - Sexp.atom "Ptyp_object"; - closedFlag flag; - Sexp.list (mapEmpty ~f:objectField fields) - ] + Sexp.list + [ + Sexp.atom "Ptyp_object"; + closedFlag flag; + Sexp.list (mapEmpty ~f:objectField fields); + ] | Ptyp_class (longidentLoc, types) -> - Sexp.list [ - Sexp.atom "Ptyp_class"; - longident longidentLoc.Location.txt; - Sexp.list (mapEmpty ~f:coreType types) - ] + Sexp.list + [ + Sexp.atom "Ptyp_class"; + longident longidentLoc.Location.txt; + Sexp.list (mapEmpty ~f:coreType types); + ] | Ptyp_variant (fields, flag, optLabels) -> - Sexp.list [ - Sexp.atom "Ptyp_variant"; - Sexp.list (mapEmpty ~f:rowField fields); - closedFlag flag; - match optLabels with - | None -> Sexp.atom "None" - | Some lbls -> Sexp.list (mapEmpty ~f:string lbls); - ] + Sexp.list + [ + Sexp.atom "Ptyp_variant"; + Sexp.list (mapEmpty ~f:rowField fields); + closedFlag flag; + (match optLabels with + | None -> Sexp.atom "None" + | Some lbls -> Sexp.list (mapEmpty ~f:string lbls)); + ] | Ptyp_poly (lbls, typexpr) -> - Sexp.list [ - Sexp.atom "Ptyp_poly"; - Sexp.list (mapEmpty ~f:(fun lbl -> string lbl.Asttypes.txt) lbls); - coreType typexpr; - ] - | Ptyp_package (package) -> - Sexp.list [ - Sexp.atom "Ptyp_package"; - packageType package; - ] - | Ptyp_extension (ext) -> - Sexp.list [ - Sexp.atom "Ptyp_extension"; - extension ext; - ] + Sexp.list + [ + Sexp.atom "Ptyp_poly"; + Sexp.list (mapEmpty ~f:(fun lbl -> string lbl.Asttypes.txt) lbls); + coreType typexpr; + ] + | Ptyp_package package -> + Sexp.list [Sexp.atom "Ptyp_package"; packageType package] + | Ptyp_extension ext -> + Sexp.list [Sexp.atom "Ptyp_extension"; extension ext] in - Sexp.list [ - Sexp.atom "core_type"; - desc; - ] + Sexp.list [Sexp.atom "core_type"; desc] and payload p = match p with - | PStr s -> - Sexp.list ( - (Sexp.atom "PStr")::(mapEmpty ~f:structureItem s) - ) - | PSig s -> - Sexp.list [ - Sexp.atom "PSig"; - signature s; - ] - | PTyp ct -> - Sexp.list [ - Sexp.atom "PTyp"; - coreType ct - ] + | PStr s -> Sexp.list (Sexp.atom "PStr" :: mapEmpty ~f:structureItem s) + | PSig s -> Sexp.list [Sexp.atom "PSig"; signature s] + | PTyp ct -> Sexp.list [Sexp.atom "PTyp"; coreType ct] | PPat (pat, optExpr) -> - Sexp.list [ - Sexp.atom "PPat"; - pattern pat; - match optExpr with - | Some expr -> Sexp.list [ - Sexp.atom "Some"; - expression expr; - ] - | None -> Sexp.atom "None"; - ] + Sexp.list + [ + Sexp.atom "PPat"; + pattern pat; + (match optExpr with + | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr] + | None -> Sexp.atom "None"); + ] and attribute (stringLoc, p) = - Sexp.list [ - Sexp.atom "attribute"; - Sexp.atom stringLoc.Asttypes.txt; - payload p; - ] + Sexp.list + [Sexp.atom "attribute"; Sexp.atom stringLoc.Asttypes.txt; payload p] and extension (stringLoc, p) = - Sexp.list [ - Sexp.atom "extension"; - Sexp.atom stringLoc.Asttypes.txt; - payload p; - ] + Sexp.list + [Sexp.atom "extension"; Sexp.atom stringLoc.Asttypes.txt; payload p] and attributes attrs = let sexprs = mapEmpty ~f:attribute attrs in - Sexp.list ((Sexp.atom "attributes")::sexprs) - - let printEngine = Res_driver.{ - printImplementation = begin fun ~width:_ ~filename:_ ~comments:_ parsetree -> - parsetree |> structure |> Sexp.toString |> print_string - end; - printInterface = begin fun ~width:_ ~filename:_ ~comments:_ parsetree -> - parsetree |> signature |> Sexp.toString |> print_string - end; - } + Sexp.list (Sexp.atom "attributes" :: sexprs) + + let printEngine = + Res_driver. + { + printImplementation = + (fun ~width:_ ~filename:_ ~comments:_ parsetree -> + parsetree |> structure |> Sexp.toString |> print_string); + printInterface = + (fun ~width:_ ~filename:_ ~comments:_ parsetree -> + parsetree |> signature |> Sexp.toString |> print_string); + } end let sexpPrintEngine = SexpAst.printEngine diff --git a/src/res_comment.ml b/src/res_comment.ml index 14670c1d..203450e5 100644 --- a/src/res_comment.ml +++ b/src/res_comment.ml @@ -1,9 +1,7 @@ -type style = - | SingleLine - | MultiLine - | DocComment +type style = SingleLine | MultiLine | DocComment -let styleToString s = match s with +let styleToString s = + match s with | SingleLine -> "SingleLine" | MultiLine -> "MultiLine" | DocComment -> "DocComment" @@ -19,8 +17,7 @@ let loc t = t.loc let txt t = t.txt let prevTokEndPos t = t.prevTokEndPos -let setPrevTokEndPos t pos = - t.prevTokEndPos <- pos +let setPrevTokEndPos t pos = t.prevTokEndPos <- pos let isSingleLineComment t = t.style = SingleLine @@ -28,50 +25,38 @@ let isDocComment t = t.style = DocComment let toString t = let {Location.loc_start; loc_end} = t.loc in - Format.sprintf - "(txt: %s\nstyle: %s\nlocation: %d,%d-%d,%d)" - t.txt - (styleToString t.style) - loc_start.pos_lnum + Format.sprintf "(txt: %s\nstyle: %s\nlocation: %d,%d-%d,%d)" t.txt + (styleToString t.style) loc_start.pos_lnum (loc_start.pos_cnum - loc_start.pos_bol) loc_end.pos_lnum (loc_end.pos_cnum - loc_end.pos_bol) -let makeSingleLineComment ~loc txt = { - txt; - loc; - style = SingleLine; - prevTokEndPos = Lexing.dummy_pos; -} +let makeSingleLineComment ~loc txt = + {txt; loc; style = SingleLine; prevTokEndPos = Lexing.dummy_pos} -let makeMultiLineComment ~loc ~docComment txt = { - txt; - loc; - style = if docComment then DocComment else MultiLine; - prevTokEndPos = Lexing.dummy_pos; -} +let makeMultiLineComment ~loc ~docComment txt = + { + txt; + loc; + style = (if docComment then DocComment else MultiLine); + prevTokEndPos = Lexing.dummy_pos; + } -let fromOcamlComment ~loc ~txt ~prevTokEndPos = { - txt; - loc; - style = MultiLine; - prevTokEndPos = prevTokEndPos -} +let fromOcamlComment ~loc ~txt ~prevTokEndPos = + {txt; loc; style = MultiLine; prevTokEndPos} let trimSpaces s = let len = String.length s in if len = 0 then s - else if String.unsafe_get s 0 = ' ' || String.unsafe_get s (len - 1) = ' ' then ( + else if String.unsafe_get s 0 = ' ' || String.unsafe_get s (len - 1) = ' ' + then ( let i = ref 0 in - while !i < len && (String.unsafe_get s !i) = ' ' do + while !i < len && String.unsafe_get s !i = ' ' do incr i done; let j = ref (len - 1) in - while !j >= !i && (String.unsafe_get s !j) = ' ' do + while !j >= !i && String.unsafe_get s !j = ' ' do decr j done; - if !j >= !i then - (String.sub [@doesNotRaise]) s !i (!j - !i + 1) - else - "" - ) else s \ No newline at end of file + if !j >= !i then (String.sub [@doesNotRaise]) s !i (!j - !i + 1) else "") + else s diff --git a/src/res_comment.mli b/src/res_comment.mli index 6bcea1e4..de306742 100644 --- a/src/res_comment.mli +++ b/src/res_comment.mli @@ -1,19 +1,19 @@ type t -val toString: t -> string +val toString : t -> string -val loc: t -> Location.t -val txt: t -> string -val prevTokEndPos: t -> Lexing.position +val loc : t -> Location.t +val txt : t -> string +val prevTokEndPos : t -> Lexing.position -val setPrevTokEndPos: t -> Lexing.position -> unit +val setPrevTokEndPos : t -> Lexing.position -> unit -val isDocComment: t -> bool +val isDocComment : t -> bool -val isSingleLineComment: t -> bool +val isSingleLineComment : t -> bool -val makeSingleLineComment: loc:Location.t -> string -> t -val makeMultiLineComment: loc:Location.t -> docComment:bool -> string -> t -val fromOcamlComment: +val makeSingleLineComment : loc:Location.t -> string -> t +val makeMultiLineComment : loc:Location.t -> docComment:bool -> string -> t +val fromOcamlComment : loc:Location.t -> txt:string -> prevTokEndPos:Lexing.position -> t -val trimSpaces: string -> string \ No newline at end of file +val trimSpaces : string -> string diff --git a/src/res_core.ml b/src/res_core.ml index ed8f35ec..2cc2e06b 100644 --- a/src/res_core.ml +++ b/src/res_core.ml @@ -3,16 +3,13 @@ module Grammar = Res_grammar module Token = Res_token module Diagnostics = Res_diagnostics module CommentTable = Res_comments_table -module ResPrinter = Res_printer +module ResPrinter = Res_printer module Scanner = Res_scanner module JsFfi = Res_js_ffi module Parser = Res_parser -let mkLoc startLoc endLoc = Location.{ - loc_start = startLoc; - loc_end = endLoc; - loc_ghost = false; -} +let mkLoc startLoc endLoc = + Location.{loc_start = startLoc; loc_end = endLoc; loc_ghost = false} module Recover = struct let defaultExpr () = @@ -44,97 +41,133 @@ module Recover = struct let rec check breadcrumbs = match breadcrumbs with | [] -> false - | (grammar, _)::rest -> - if Grammar.isPartOfList grammar p.Parser.token then - true - else - check rest + | (grammar, _) :: rest -> + if Grammar.isPartOfList grammar p.Parser.token then true else check rest in check p.breadcrumbs end module ErrorMessages = struct - let listPatternSpread = "List pattern matches only supports one `...` spread, at the end.\n\ -Explanation: a list spread at the tail is efficient, but a spread in the middle would create new list[s]; out of performance concern, our pattern matching currently guarantees to never create new intermediate data." - - let recordPatternSpread = "Record's `...` spread is not supported in pattern matches.\n\ -Explanation: you can't collect a subset of a record's field into its own record, since a record needs an explicit declaration and that subset wouldn't have one.\n\ -Solution: you need to pull out each field you want explicitly." - - (* let recordPatternUnderscore = "Record patterns only support one `_`, at the end." *) - [@@live] - - let arrayPatternSpread = "Array's `...` spread is not supported in pattern matches.\n\ -Explanation: such spread would create a subarray; out of performance concern, our pattern matching currently guarantees to never create new intermediate data.\n\ -Solution: if it's to validate the first few elements, use a `when` clause + Array size check + `get` checks on the current pattern. If it's to obtain a subarray, use `Array.sub` or `Belt.Array.slice`." - - let arrayExprSpread = "Arrays can't use the `...` spread currently. Please use `concat` or other Array helpers." - - let recordExprSpread = "Records can only have one `...` spread, at the beginning.\n\ -Explanation: since records have a known, fixed shape, a spread like `{a, ...b}` wouldn't make sense, as `b` would override every field of `a` anyway." - - let listExprSpread = "Lists can only have one `...` spread, and at the end.\n\ -Explanation: lists are singly-linked list, where a node contains a value and points to the next node. `list[a, ...bc]` efficiently creates a new item and links `bc` as its next nodes. `[...bc, a]` would be expensive, as it'd need to traverse `bc` and prepend each item to `a` one by one. We therefore disallow such syntax sugar.\n\ -Solution: directly use `concat`." - - let variantIdent = "A polymorphic variant (e.g. #id) must start with an alphabetical letter or be a number (e.g. #742)" + let listPatternSpread = + "List pattern matches only supports one `...` spread, at the end.\n\ + Explanation: a list spread at the tail is efficient, but a spread in the \ + middle would create new list[s]; out of performance concern, our pattern \ + matching currently guarantees to never create new intermediate data." + + let recordPatternSpread = + "Record's `...` spread is not supported in pattern matches.\n\ + Explanation: you can't collect a subset of a record's field into its own \ + record, since a record needs an explicit declaration and that subset \ + wouldn't have one.\n\ + Solution: you need to pull out each field you want explicitly." + (* let recordPatternUnderscore = "Record patterns only support one `_`, at the end." *) + [@@live] + + let arrayPatternSpread = + "Array's `...` spread is not supported in pattern matches.\n\ + Explanation: such spread would create a subarray; out of performance \ + concern, our pattern matching currently guarantees to never create new \ + intermediate data.\n\ + Solution: if it's to validate the first few elements, use a `when` clause \ + + Array size check + `get` checks on the current pattern. If it's to \ + obtain a subarray, use `Array.sub` or `Belt.Array.slice`." + + let arrayExprSpread = + "Arrays can't use the `...` spread currently. Please use `concat` or other \ + Array helpers." + + let recordExprSpread = + "Records can only have one `...` spread, at the beginning.\n\ + Explanation: since records have a known, fixed shape, a spread like `{a, \ + ...b}` wouldn't make sense, as `b` would override every field of `a` \ + anyway." + + let listExprSpread = + "Lists can only have one `...` spread, and at the end.\n\ + Explanation: lists are singly-linked list, where a node contains a value \ + and points to the next node. `list[a, ...bc]` efficiently creates a new \ + item and links `bc` as its next nodes. `[...bc, a]` would be expensive, \ + as it'd need to traverse `bc` and prepend each item to `a` one by one. We \ + therefore disallow such syntax sugar.\n\ + Solution: directly use `concat`." + + let variantIdent = + "A polymorphic variant (e.g. #id) must start with an alphabetical letter \ + or be a number (e.g. #742)" let experimentalIfLet expr = let switchExpr = {expr with Parsetree.pexp_attributes = []} in - Doc.concat [ - Doc.text "If-let is currently highly experimental."; - Doc.line; - Doc.text "Use a regular `switch` with pattern matching instead:"; - Doc.concat [ - Doc.hardLine; - Doc.hardLine; - ResPrinter.printExpression switchExpr (CommentTable.empty); + Doc.concat + [ + Doc.text "If-let is currently highly experimental."; + Doc.line; + Doc.text "Use a regular `switch` with pattern matching instead:"; + Doc.concat + [ + Doc.hardLine; + Doc.hardLine; + ResPrinter.printExpression switchExpr CommentTable.empty; + ]; ] - ] |> Doc.toString ~width:80 + |> Doc.toString ~width:80 - let typeParam = "A type param consists of a singlequote followed by a name like `'a` or `'A`" - let typeVar = "A type variable consists of a singlequote followed by a name like `'a` or `'A`" + let typeParam = + "A type param consists of a singlequote followed by a name like `'a` or \ + `'A`" + let typeVar = + "A type variable consists of a singlequote followed by a name like `'a` or \ + `'A`" let attributeWithoutNode (attr : Parsetree.attribute) = - let ({Asttypes.txt = attrName}, _) = attr in - "Did you forget to attach `" ^ attrName ^ "` to an item?\n Standalone attributes start with `@@` like: `@@" ^ attrName ^"`" + let {Asttypes.txt = attrName}, _ = attr in + "Did you forget to attach `" ^ attrName + ^ "` to an item?\n Standalone attributes start with `@@` like: `@@" + ^ attrName ^ "`" let typeDeclarationNameLongident longident = - "A type declaration's name cannot contain a module access. Did you mean `" ^ (Longident.last longident) ^"`?" + "A type declaration's name cannot contain a module access. Did you mean `" + ^ Longident.last longident ^ "`?" let tupleSingleElement = "A tuple needs at least two elements" let missingTildeLabeledParameter name = - if name = "" then - "A labeled parameter starts with a `~`." - else - ("A labeled parameter starts with a `~`. Did you mean: `~" ^ name ^ "`?") + if name = "" then "A labeled parameter starts with a `~`." + else "A labeled parameter starts with a `~`. Did you mean: `~" ^ name ^ "`?" let stringInterpolationInPattern = "String interpolation is not supported in pattern matching." let spreadInRecordDeclaration = - "A record type declaration doesn't support the ... spread. Only an object (with quoted field names) does." + "A record type declaration doesn't support the ... spread. Only an object \ + (with quoted field names) does." let objectQuotedFieldName name = - "An object type declaration needs quoted field names. Did you mean \"" ^ name ^ "\"?" + "An object type declaration needs quoted field names. Did you mean \"" + ^ name ^ "\"?" let forbiddenInlineRecordDeclaration = - "An inline record type declaration is only allowed in a variant constructor's declaration" + "An inline record type declaration is only allowed in a variant \ + constructor's declaration" let sameTypeSpread = "You're using a ... spread without extra fields. This is the same type." let polyVarIntWithSuffix number = - "A numeric polymorphic variant cannot be followed by a letter. Did you mean `#" ^ number ^ "`?" + "A numeric polymorphic variant cannot be followed by a letter. Did you \ + mean `#" ^ number ^ "`?" end - let jsxAttr = (Location.mknoloc "JSX", Parsetree.PStr []) let uncurryAttr = (Location.mknoloc "bs", Parsetree.PStr []) let ternaryAttr = (Location.mknoloc "ns.ternary", Parsetree.PStr []) let ifLetAttr = (Location.mknoloc "ns.iflet", Parsetree.PStr []) -let suppressFragileMatchWarningAttr = (Location.mknoloc "warning", Parsetree.PStr [Ast_helper.Str.eval (Ast_helper.Exp.constant (Pconst_string ("-4", None)))]) +let suppressFragileMatchWarningAttr = + ( Location.mknoloc "warning", + Parsetree.PStr + [ + Ast_helper.Str.eval + (Ast_helper.Exp.constant (Pconst_string ("-4", None))); + ] ) let makeBracesAttr loc = (Location.mkloc "ns.braces" loc, Parsetree.PStr []) let templateLiteralAttr = (Location.mknoloc "res.template", Parsetree.PStr []) @@ -150,23 +183,33 @@ type stringLiteralState = | EscapedLineBreak type typDefOrExt = - | TypeDef of {recFlag: Asttypes.rec_flag; types: Parsetree.type_declaration list} + | TypeDef of { + recFlag: Asttypes.rec_flag; + types: Parsetree.type_declaration list; + } | TypeExt of Parsetree.type_extension type labelledParameter = - | TermParameter of - {uncurried: bool; attrs: Parsetree.attributes; label: Asttypes.arg_label; expr: Parsetree.expression option; - pat: Parsetree.pattern; pos: Lexing.position} - | TypeParameter of {uncurried: bool; attrs: Parsetree.attributes; locs: string Location.loc list; pos: Lexing.position} + | TermParameter of { + uncurried: bool; + attrs: Parsetree.attributes; + label: Asttypes.arg_label; + expr: Parsetree.expression option; + pat: Parsetree.pattern; + pos: Lexing.position; + } + | TypeParameter of { + uncurried: bool; + attrs: Parsetree.attributes; + locs: string Location.loc list; + pos: Lexing.position; + } type recordPatternItem = | PatUnderscore | PatField of (Ast_helper.lid * Parsetree.pattern) -type context = - | OrdinaryExpr - | TernaryTrueBranchExpr - | WhenExpr +type context = OrdinaryExpr | TernaryTrueBranchExpr | WhenExpr let getClosingToken = function | Token.Lparen -> Token.Rparen @@ -178,14 +221,17 @@ let getClosingToken = function let rec goToClosing closingToken state = match (state.Parser.token, closingToken) with - | (Rparen, Token.Rparen) | (Rbrace, Rbrace) | (Rbracket, Rbracket) | (GreaterThan, GreaterThan) -> + | Rparen, Token.Rparen + | Rbrace, Rbrace + | Rbracket, Rbracket + | GreaterThan, GreaterThan -> Parser.next state; () - | (Token.Lbracket | Lparen | Lbrace | List | LessThan) as t, _ -> + | ((Token.Lbracket | Lparen | Lbrace | List | LessThan) as t), _ -> Parser.next state; goToClosing (getClosingToken t) state; goToClosing closingToken state - | ((Rparen | Token.Rbrace | Rbracket | Eof), _) -> + | (Rparen | Token.Rbrace | Rbracket | Eof), _ -> () (* TODO: how do report errors here? *) | _ -> Parser.next state; @@ -194,141 +240,128 @@ let rec goToClosing closingToken state = (* Madness *) let isEs6ArrowExpression ~inTernary p = Parser.lookahead p (fun state -> - match state.Parser.token with - | Lident _ | Underscore -> - Parser.next state; - begin match state.Parser.token with - (* Don't think that this valid - * Imagine: let x = (a: int) - * This is a parenthesized expression with a type constraint, wait for - * the arrow *) - (* | Colon when not inTernary -> true *) - | EqualGreater -> true - | _ -> false - end - | Lparen -> - let prevEndPos = state.prevEndPos in - Parser.next state; - begin match state.token with - (* arrived at `()` here *) - | Rparen -> + match state.Parser.token with + | Lident _ | Underscore -> ( Parser.next state; - begin match state.Parser.token with - (* arrived at `() :` here *) - | Colon when not inTernary -> + match state.Parser.token with + (* Don't think that this valid + * Imagine: let x = (a: int) + * This is a parenthesized expression with a type constraint, wait for + * the arrow *) + (* | Colon when not inTernary -> true *) + | EqualGreater -> true + | _ -> false) + | Lparen -> ( + let prevEndPos = state.prevEndPos in + Parser.next state; + match state.token with + (* arrived at `()` here *) + | Rparen -> ( Parser.next state; - begin match state.Parser.token with - (* arrived at `() :typ` here *) - | Lident _ -> + match state.Parser.token with + (* arrived at `() :` here *) + | Colon when not inTernary -> ( Parser.next state; - begin match state.Parser.token with - (* arrived at `() :typ<` here *) - | LessThan -> + match state.Parser.token with + (* arrived at `() :typ` here *) + | Lident _ -> ( Parser.next state; - goToClosing GreaterThan state; - | _ -> () - end; - begin match state.Parser.token with - (* arrived at `() :typ =>` or `() :typ<'a,'b> =>` here *) - | EqualGreater -> - true - | _ -> false - end - | _ -> true - end - | EqualGreater -> true - | _ -> false - end - | Dot (* uncurried *) -> true - | Tilde -> true - | Backtick -> false (* (` always indicates the start of an expr, can't be es6 parameter *) - | _ -> - goToClosing Rparen state; - begin match state.Parser.token with - | EqualGreater -> true - (* | Lbrace TODO: detect missing =>, is this possible? *) - | Colon when not inTernary -> true - | Rparen -> - (* imagine having something as : - * switch colour { - * | Red - * when l == l' - * || (&Clflags.classic && (l == Nolabel && !is_optional(l'))) => (t1, t2) - * We'll arrive at the outer rparen just before the =>. - * This is not an es6 arrow. - * *) + (match state.Parser.token with + (* arrived at `() :typ<` here *) + | LessThan -> + Parser.next state; + goToClosing GreaterThan state + | _ -> ()); + match state.Parser.token with + (* arrived at `() :typ =>` or `() :typ<'a,'b> =>` here *) + | EqualGreater -> true + | _ -> false) + | _ -> true) + | EqualGreater -> true + | _ -> false) + | Dot (* uncurried *) -> true + | Tilde -> true + | Backtick -> false - | _ -> - Parser.nextUnsafe state; - (* error recovery, peek at the next token, - * (elements, providerId] => { - * in the example above, we have an unbalanced ] here - *) - begin match state.Parser.token with - | EqualGreater when state.startPos.pos_lnum == prevEndPos.pos_lnum -> true - | _ -> false - end - end - end - | _ -> false) - + (* (` always indicates the start of an expr, can't be es6 parameter *) + | _ -> ( + goToClosing Rparen state; + match state.Parser.token with + | EqualGreater -> true + (* | Lbrace TODO: detect missing =>, is this possible? *) + | Colon when not inTernary -> true + | Rparen -> + (* imagine having something as : + * switch colour { + * | Red + * when l == l' + * || (&Clflags.classic && (l == Nolabel && !is_optional(l'))) => (t1, t2) + * We'll arrive at the outer rparen just before the =>. + * This is not an es6 arrow. + * *) + false + | _ -> ( + Parser.nextUnsafe state; + (* error recovery, peek at the next token, + * (elements, providerId] => { + * in the example above, we have an unbalanced ] here + *) + match state.Parser.token with + | EqualGreater when state.startPos.pos_lnum == prevEndPos.pos_lnum + -> + true + | _ -> false))) + | _ -> false) let isEs6ArrowFunctor p = Parser.lookahead p (fun state -> - match state.Parser.token with - (* | Uident _ | Underscore -> *) + match state.Parser.token with + (* | Uident _ | Underscore -> *) (* Parser.next state; *) (* begin match state.Parser.token with *) (* | EqualGreater -> true *) (* | _ -> false *) (* end *) - | Lparen -> - Parser.next state; - begin match state.token with - | Rparen -> + | Lparen -> ( Parser.next state; - begin match state.token with - | Colon | EqualGreater -> true - | _ -> false - end - | _ -> - goToClosing Rparen state; - begin match state.Parser.token with - | EqualGreater | Lbrace -> true - | Colon -> true - | _ -> false - end - end - | _ -> false - ) + match state.token with + | Rparen -> ( + Parser.next state; + match state.token with + | Colon | EqualGreater -> true + | _ -> false) + | _ -> ( + goToClosing Rparen state; + match state.Parser.token with + | EqualGreater | Lbrace -> true + | Colon -> true + | _ -> false)) + | _ -> false) let isEs6ArrowType p = Parser.lookahead p (fun state -> - match state.Parser.token with - | Lparen -> - Parser.next state; - begin match state.Parser.token with - | Rparen -> + match state.Parser.token with + | Lparen -> ( Parser.next state; - begin match state.Parser.token with - | EqualGreater -> true - | _ -> false - end - | Tilde | Dot -> true - | _ -> - goToClosing Rparen state; - begin match state.Parser.token with - | EqualGreater -> true - | _ -> false - end - end - | Tilde -> true - | _ -> false - ) + match state.Parser.token with + | Rparen -> ( + Parser.next state; + match state.Parser.token with + | EqualGreater -> true + | _ -> false) + | Tilde | Dot -> true + | _ -> ( + goToClosing Rparen state; + match state.Parser.token with + | EqualGreater -> true + | _ -> false)) + | Tilde -> true + | _ -> false) -let buildLongident words = match List.rev words with +let buildLongident words = + match List.rev words with | [] -> assert false - | hd::tl -> List.fold_left (fun p s -> Longident.Ldot (p, s)) (Lident hd) tl + | hd :: tl -> List.fold_left (fun p s -> Longident.Ldot (p, s)) (Lident hd) tl let makeInfixOperator p token startPos endPos = let stringifiedToken = @@ -338,66 +371,63 @@ let makeInfixOperator p token startPos endPos = else if token = Token.BangEqualEqual then "!=" else if token = Token.Equal then ( (* TODO: could have a totally different meaning like x->fooSet(y)*) - Parser.err ~startPos ~endPos p ( - Diagnostics.message "Did you mean `==` here?" - ); - "=" - ) else if token = Token.EqualEqual then "=" + Parser.err ~startPos ~endPos p + (Diagnostics.message "Did you mean `==` here?"); + "=") + else if token = Token.EqualEqual then "=" else if token = Token.EqualEqualEqual then "==" else Token.toString token in let loc = mkLoc startPos endPos in - let operator = Location.mkloc - (Longident.Lident stringifiedToken) loc - in + let operator = Location.mkloc (Longident.Lident stringifiedToken) loc in Ast_helper.Exp.ident ~loc operator let negateString s = - if String.length s > 0 && (s.[0] [@doesNotRaise]) = '-' - then (String.sub [@doesNotRaise]) s 1 (String.length s - 1) + if String.length s > 0 && (s.[0] [@doesNotRaise]) = '-' then + (String.sub [@doesNotRaise]) s 1 (String.length s - 1) else "-" ^ s let makeUnaryExpr startPos tokenEnd token operand = - match token, operand.Parsetree.pexp_desc with - | (Token.Plus | PlusDot), Pexp_constant((Pconst_integer _ | Pconst_float _)) -> + match (token, operand.Parsetree.pexp_desc) with + | (Token.Plus | PlusDot), Pexp_constant (Pconst_integer _ | Pconst_float _) -> operand - | Minus, Pexp_constant(Pconst_integer (n,m)) -> - {operand with pexp_desc = Pexp_constant(Pconst_integer (negateString n,m))} - | (Minus | MinusDot), Pexp_constant(Pconst_float (n,m)) -> - {operand with pexp_desc = Pexp_constant(Pconst_float (negateString n,m))} - | (Token.Plus | PlusDot | Minus | MinusDot ), _ -> + | Minus, Pexp_constant (Pconst_integer (n, m)) -> + { + operand with + pexp_desc = Pexp_constant (Pconst_integer (negateString n, m)); + } + | (Minus | MinusDot), Pexp_constant (Pconst_float (n, m)) -> + {operand with pexp_desc = Pexp_constant (Pconst_float (negateString n, m))} + | (Token.Plus | PlusDot | Minus | MinusDot), _ -> let tokenLoc = mkLoc startPos tokenEnd in let operator = "~" ^ Token.toString token in Ast_helper.Exp.apply ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) (Ast_helper.Exp.ident ~loc:tokenLoc - (Location.mkloc (Longident.Lident operator) tokenLoc)) - [Nolabel, operand] + (Location.mkloc (Longident.Lident operator) tokenLoc)) + [(Nolabel, operand)] | Token.Bang, _ -> let tokenLoc = mkLoc startPos tokenEnd in Ast_helper.Exp.apply ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) (Ast_helper.Exp.ident ~loc:tokenLoc - (Location.mkloc (Longident.Lident "not") tokenLoc)) - [Nolabel, operand] - | _ -> - operand + (Location.mkloc (Longident.Lident "not") tokenLoc)) + [(Nolabel, operand)] + | _ -> operand let makeListExpression loc seq extOpt = let rec handleSeq = function - | [] -> - begin match extOpt with + | [] -> ( + match extOpt with | Some ext -> ext | None -> let loc = {loc with Location.loc_ghost = true} in let nil = Location.mkloc (Longident.Lident "[]") loc in - Ast_helper.Exp.construct ~loc nil None - end + Ast_helper.Exp.construct ~loc nil None) | e1 :: el -> let exp_el = handleSeq el in - let loc = mkLoc - e1.Parsetree.pexp_loc.Location.loc_start - exp_el.pexp_loc.loc_end + let loc = + mkLoc e1.Parsetree.pexp_loc.Location.loc_start exp_el.pexp_loc.loc_end in let arg = Ast_helper.Exp.tuple ~loc [e1; exp_el] in Ast_helper.Exp.construct ~loc @@ -409,22 +439,22 @@ let makeListExpression loc seq extOpt = let makeListPattern loc seq ext_opt = let rec handle_seq = function - [] -> - let base_case = match ext_opt with - | Some ext -> - ext + | [] -> + let base_case = + match ext_opt with + | Some ext -> ext | None -> - let loc = { loc with Location.loc_ghost = true} in - let nil = { Location.txt = Longident.Lident "[]"; loc } in + let loc = {loc with Location.loc_ghost = true} in + let nil = {Location.txt = Longident.Lident "[]"; loc} in Ast_helper.Pat.construct ~loc nil None in base_case - | p1 :: pl -> + | p1 :: pl -> let pat_pl = handle_seq pl in - let loc = - mkLoc p1.Parsetree.ppat_loc.loc_start pat_pl.ppat_loc.loc_end in + let loc = mkLoc p1.Parsetree.ppat_loc.loc_start pat_pl.ppat_loc.loc_end in let arg = Ast_helper.Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in - Ast_helper.Pat.mk ~loc (Ppat_construct(Location.mkloc (Longident.Lident "::") loc, Some arg)) + Ast_helper.Pat.mk ~loc + (Ppat_construct (Location.mkloc (Longident.Lident "::") loc, Some arg)) in handle_seq seq @@ -432,13 +462,15 @@ let makeListPattern loc seq ext_opt = let lidentOfPath longident = match Longident.flatten longident |> List.rev with | [] -> "" - | ident::_ -> ident + | ident :: _ -> ident let makeNewtypes ~attrs ~loc newtypes exp = - let expr = List.fold_right (fun newtype exp -> - Ast_helper.Exp.mk ~loc (Pexp_newtype (newtype, exp)) - ) newtypes exp - in {expr with pexp_attributes = attrs} + let expr = + List.fold_right + (fun newtype exp -> Ast_helper.Exp.mk ~loc (Pexp_newtype (newtype, exp))) + newtypes exp + in + {expr with pexp_attributes = attrs} (* locally abstract types syntax sugar * Transforms @@ -447,11 +479,13 @@ let makeNewtypes ~attrs ~loc newtypes exp = * let f = (type t u v. foo : list) => ... *) let wrapTypeAnnotation ~loc newtypes core_type body = - let exp = makeNewtypes ~attrs:[] ~loc newtypes - (Ast_helper.Exp.constraint_ ~loc body core_type) + let exp = + makeNewtypes ~attrs:[] ~loc newtypes + (Ast_helper.Exp.constraint_ ~loc body core_type) in - let typ = Ast_helper.Typ.poly ~loc newtypes - (Ast_helper.Typ.varify_constructors newtypes core_type) + let typ = + Ast_helper.Typ.poly ~loc newtypes + (Ast_helper.Typ.varify_constructors newtypes core_type) in (exp, typ) @@ -466,36 +500,41 @@ let processUnderscoreApplication args = let hidden_var = "__x" in let check_arg ((lab, exp) as arg) = match exp.Parsetree.pexp_desc with - | Pexp_ident ({ txt = Lident "_"} as id) -> + | Pexp_ident ({txt = Lident "_"} as id) -> let new_id = Location.mkloc (Longident.Lident hidden_var) id.loc in let new_exp = Ast_helper.Exp.mk (Pexp_ident new_id) ~loc:exp.pexp_loc in exp_question := Some new_exp; (lab, new_exp) - | _ -> - arg + | _ -> arg in let args = List.map check_arg args in let wrap exp_apply = match !exp_question with - | Some {pexp_loc=loc} -> - let pattern = Ast_helper.Pat.mk (Ppat_var (Location.mkloc hidden_var loc)) ~loc in + | Some {pexp_loc = loc} -> + let pattern = + Ast_helper.Pat.mk (Ppat_var (Location.mkloc hidden_var loc)) ~loc + in Ast_helper.Exp.mk (Pexp_fun (Nolabel, None, pattern, exp_apply)) ~loc - | None -> - exp_apply + | None -> exp_apply in (args, wrap) let hexValue ch = match ch with - | '0'..'9' -> (Char.code ch) - 48 - | 'a'..'f' -> (Char.code ch) - (Char.code 'a') + 10 - | 'A'..'F' -> (Char.code ch) + 32 - (Char.code 'a') + 10 + | '0' .. '9' -> Char.code ch - 48 + | 'a' .. 'f' -> Char.code ch - Char.code 'a' + 10 + | 'A' .. 'F' -> Char.code ch + 32 - Char.code 'a' + 10 | _ -> 16 (* larger than any legal value *) (* Transform A.a into a. For use with punned record fields as in {A.a, b}. *) let removeModuleNameFromPunnedFieldValue exp = match exp.Parsetree.pexp_desc with - | Pexp_ident pathIdent -> {exp with pexp_desc = Pexp_ident { pathIdent with txt = Lident (Longident.last pathIdent.txt) }} + | Pexp_ident pathIdent -> + { + exp with + pexp_desc = + Pexp_ident {pathIdent with txt = Lident (Longident.last pathIdent.txt)}; + } | _ -> exp let parseStringLiteral s = @@ -504,69 +543,88 @@ let parseStringLiteral s = let rec parse state i d = if i = len then - (match state with - | HexEscape | DecimalEscape | OctalEscape | UnicodeEscape | UnicodeCodePointEscape -> false - | _ -> true) + match state with + | HexEscape | DecimalEscape | OctalEscape | UnicodeEscape + | UnicodeCodePointEscape -> + false + | _ -> true else let c = String.unsafe_get s i in match state with - | Start -> - (match c with + | Start -> ( + match c with | '\\' -> parse Backslash (i + 1) d - | c -> Buffer.add_char b c; parse Start (i + 1) d) - | Backslash -> - (match c with - | 'n' -> Buffer.add_char b '\n'; parse Start (i + 1) d - | 'r' -> Buffer.add_char b '\r'; parse Start (i + 1) d - | 'b' -> Buffer.add_char b '\008'; parse Start (i + 1) d - | 't' -> Buffer.add_char b '\009'; parse Start (i + 1) d - | ('\\' | ' ' | '\'' | '"') as c -> Buffer.add_char b c; parse Start (i + 1) d + | c -> + Buffer.add_char b c; + parse Start (i + 1) d) + | Backslash -> ( + match c with + | 'n' -> + Buffer.add_char b '\n'; + parse Start (i + 1) d + | 'r' -> + Buffer.add_char b '\r'; + parse Start (i + 1) d + | 'b' -> + Buffer.add_char b '\008'; + parse Start (i + 1) d + | 't' -> + Buffer.add_char b '\009'; + parse Start (i + 1) d + | ('\\' | ' ' | '\'' | '"') as c -> + Buffer.add_char b c; + parse Start (i + 1) d | 'x' -> parse HexEscape (i + 1) 0 | 'o' -> parse OctalEscape (i + 1) 0 | 'u' -> parse UnicodeEscapeStart (i + 1) 0 | '0' .. '9' -> parse DecimalEscape i 0 | '\010' | '\013' -> parse EscapedLineBreak (i + 1) d - | c -> Buffer.add_char b '\\'; Buffer.add_char b c; parse Start (i + 1) d) + | c -> + Buffer.add_char b '\\'; + Buffer.add_char b c; + parse Start (i + 1) d) | HexEscape -> if d == 1 then let c0 = String.unsafe_get s (i - 1) in let c1 = String.unsafe_get s i in - let c = (16 * (hexValue c0)) + (hexValue c1) in + let c = (16 * hexValue c0) + hexValue c1 in if c < 0 || c > 255 then false else ( Buffer.add_char b (Char.unsafe_chr c); - parse Start (i + 1) 0 - ) - else - parse HexEscape (i + 1) (d + 1) + parse Start (i + 1) 0) + else parse HexEscape (i + 1) (d + 1) | DecimalEscape -> if d == 2 then let c0 = String.unsafe_get s (i - 2) in let c1 = String.unsafe_get s (i - 1) in let c2 = String.unsafe_get s i in - let c = 100 * (Char.code c0 - 48) + 10 * (Char.code c1 - 48) + (Char.code c2 - 48) in + let c = + (100 * (Char.code c0 - 48)) + + (10 * (Char.code c1 - 48)) + + (Char.code c2 - 48) + in if c < 0 || c > 255 then false else ( Buffer.add_char b (Char.unsafe_chr c); - parse Start (i + 1) 0 - ) - else - parse DecimalEscape (i + 1) (d + 1) + parse Start (i + 1) 0) + else parse DecimalEscape (i + 1) (d + 1) | OctalEscape -> if d == 2 then let c0 = String.unsafe_get s (i - 2) in let c1 = String.unsafe_get s (i - 1) in let c2 = String.unsafe_get s i in - let c = 64 * (Char.code c0 - 48) + 8 * (Char.code c1 - 48) + (Char.code c2 - 48) in + let c = + (64 * (Char.code c0 - 48)) + + (8 * (Char.code c1 - 48)) + + (Char.code c2 - 48) + in if c < 0 || c > 255 then false else ( Buffer.add_char b (Char.unsafe_chr c); - parse Start (i + 1) 0 - ) - else - parse OctalEscape (i + 1) (d + 1) - | UnicodeEscapeStart -> - (match c with + parse Start (i + 1) 0) + else parse OctalEscape (i + 1) (d + 1) + | UnicodeEscapeStart -> ( + match c with | '{' -> parse UnicodeCodePointEscape (i + 1) 0 | _ -> parse UnicodeEscape (i + 1) 1) | UnicodeEscape -> @@ -575,59 +633,58 @@ let parseStringLiteral s = let c1 = String.unsafe_get s (i - 2) in let c2 = String.unsafe_get s (i - 1) in let c3 = String.unsafe_get s i in - let c = (4096 * (hexValue c0)) + (256 * (hexValue c1)) + (16 * (hexValue c2)) + (hexValue c3) in + let c = + (4096 * hexValue c0) + + (256 * hexValue c1) + + (16 * hexValue c2) + + hexValue c3 + in if Res_utf8.isValidCodePoint c then ( let codePoint = Res_utf8.encodeCodePoint c in Buffer.add_string b codePoint; - parse Start (i + 1) 0 - ) else ( - false - ) - else - parse UnicodeEscape (i + 1) (d + 1) - | UnicodeCodePointEscape -> - (match c with - | '0'..'9' | 'a'..'f' | 'A'.. 'F' -> + parse Start (i + 1) 0) + else false + else parse UnicodeEscape (i + 1) (d + 1) + | UnicodeCodePointEscape -> ( + match c with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> parse UnicodeCodePointEscape (i + 1) (d + 1) | '}' -> let x = ref 0 in for remaining = d downto 1 do let ix = i - remaining in - x := (!x * 16) + (hexValue (String.unsafe_get s ix)); + x := (!x * 16) + hexValue (String.unsafe_get s ix) done; let c = !x in if Res_utf8.isValidCodePoint c then ( let codePoint = Res_utf8.encodeCodePoint !x in Buffer.add_string b codePoint; - parse Start (i + 1) 0 - ) else ( - false - ) + parse Start (i + 1) 0) + else false | _ -> false) - | EscapedLineBreak -> - (match c with + | EscapedLineBreak -> ( + match c with | ' ' | '\t' -> parse EscapedLineBreak (i + 1) d - | c -> Buffer.add_char b c; parse Start (i + 1) d) - in - if parse Start 0 0 then Buffer.contents b else s + | c -> + Buffer.add_char b c; + parse Start (i + 1) d) + in + if parse Start 0 0 then Buffer.contents b else s let rec parseLident p = let recoverLident p = - if ( - Token.isKeyword p.Parser.token && - p.Parser.prevEndPos.pos_lnum == p.startPos.pos_lnum - ) + if + Token.isKeyword p.Parser.token + && p.Parser.prevEndPos.pos_lnum == p.startPos.pos_lnum then ( Parser.err p (Diagnostics.lident p.Parser.token); Parser.next p; - None - ) else ( + None) + else let rec loop p = - if not (Recover.shouldAbortListParse p) && p.token <> Eof - then begin + if (not (Recover.shouldAbortListParse p)) && p.token <> Eof then ( Parser.next p; - loop p - end + loop p) in Parser.err p (Diagnostics.lident p.Parser.token); Parser.next p; @@ -635,7 +692,6 @@ let rec parseLident p = match p.Parser.token with | Lident _ -> Some () | _ -> None - ) in let startPos = p.Parser.startPos in match p.Parser.token with @@ -643,26 +699,25 @@ let rec parseLident p = Parser.next p; let loc = mkLoc startPos p.prevEndPos in (ident, loc) - | _ -> - begin match recoverLident p with - | Some () -> - parseLident p - | None -> - ("_", mkLoc startPos p.prevEndPos) - end + | _ -> ( + match recoverLident p with + | Some () -> parseLident p + | None -> ("_", mkLoc startPos p.prevEndPos)) let parseIdent ~msg ~startPos p = match p.Parser.token with - | Lident ident - | Uident ident -> + | Lident ident | Uident ident -> Parser.next p; let loc = mkLoc startPos p.prevEndPos in (ident, loc) - | token when Token.isKeyword token && - p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + | token + when Token.isKeyword token && p.prevEndPos.pos_lnum == p.startPos.pos_lnum + -> let tokenTxt = Token.toString token in let msg = - "`" ^ tokenTxt ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ tokenTxt ^ "\"" + "`" ^ tokenTxt + ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ tokenTxt + ^ "\"" in Parser.err ~startPos p (Diagnostics.message msg); Parser.next p; @@ -676,67 +731,69 @@ let parseHashIdent ~startPos p = Parser.expect Hash p; match p.token with | String text -> - let text = if p.mode = ParseForTypeChecker then parseStringLiteral text else text in + let text = + if p.mode = ParseForTypeChecker then parseStringLiteral text else text + in Parser.next p; (text, mkLoc startPos p.prevEndPos) | Int {i; suffix} -> - let () = match suffix with - | Some _ -> - Parser.err p (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) - | None -> () + let () = + match suffix with + | Some _ -> + Parser.err p + (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) + | None -> () in Parser.next p; (i, mkLoc startPos p.prevEndPos) - | _ -> - parseIdent ~startPos ~msg:ErrorMessages.variantIdent p + | _ -> parseIdent ~startPos ~msg:ErrorMessages.variantIdent p (* Ldot (Ldot (Lident "Foo", "Bar"), "baz") *) let parseValuePath p = let startPos = p.Parser.startPos in let rec aux p path = match p.Parser.token with - | Lident ident -> Longident.Ldot(path, ident) + | Lident ident -> Longident.Ldot (path, ident) | Uident uident -> Parser.next p; if p.Parser.token = Dot then ( Parser.expect Dot p; - aux p (Ldot (path, uident)) - ) else ( + aux p (Ldot (path, uident))) + else ( Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - path - ) + path) | token -> Parser.err p (Diagnostics.unexpected token p.breadcrumbs); Longident.Ldot (path, "_") in - let ident = match p.Parser.token with - | Lident ident -> - Parser.next p; - Longident.Lident ident - | Uident ident -> - Parser.next p; - let res = if p.Parser.token = Dot then ( - Parser.expect Dot p; - aux p (Lident ident) - ) else ( - Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + let ident = + match p.Parser.token with + | Lident ident -> + Parser.next p; Longident.Lident ident - ) in - if p.token <> Eof then Parser.next p; - res - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Parser.next p; - Longident.Lident "_" + | Uident ident -> + Parser.next p; + let res = + if p.Parser.token = Dot then ( + Parser.expect Dot p; + aux p (Lident ident)) + else ( + Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + Longident.Lident ident) + in + if p.token <> Eof then Parser.next p; + res + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Parser.next p; + Longident.Lident "_" in Location.mkloc ident (mkLoc startPos p.prevEndPos) let parseValuePathAfterDot p = let startPos = p.Parser.startPos in match p.Parser.token with - | Lident _ - | Uident _ -> - parseValuePath p + | Lident _ | Uident _ -> parseValuePath p | token -> Parser.err p (Diagnostics.unexpected token p.breadcrumbs); Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) @@ -746,7 +803,9 @@ let parseValuePathTail p startPos ident = match p.Parser.token with | Lident ident -> Parser.next p; - Location.mkloc (Longident.Ldot(path, ident)) (mkLoc startPos p.prevEndPos) + Location.mkloc + (Longident.Ldot (path, ident)) + (mkLoc startPos p.prevEndPos) | Uident ident -> Parser.next p; Parser.expect Dot p; @@ -762,18 +821,17 @@ let parseModuleLongIdentTail ~lowercase p startPos ident = match p.Parser.token with | Lident ident when lowercase -> Parser.next p; - let lident = (Longident.Ldot (acc, ident)) in + let lident = Longident.Ldot (acc, ident) in Location.mkloc lident (mkLoc startPos p.prevEndPos) - | Uident ident -> + | Uident ident -> ( Parser.next p; let endPos = p.prevEndPos in - let lident = (Longident.Ldot (acc, ident)) in - begin match p.Parser.token with + let lident = Longident.Ldot (acc, ident) in + match p.Parser.token with | Dot -> Parser.next p; loop p lident - | _ -> Location.mkloc lident (mkLoc startPos endPos) - end + | _ -> Location.mkloc lident (mkLoc startPos endPos)) | t -> Parser.err p (Diagnostics.uident t); Location.mkloc (Longident.Ldot (acc, "_")) (mkLoc startPos p.prevEndPos) @@ -786,25 +844,25 @@ let parseModuleLongIdentTail ~lowercase p startPos ident = let parseModuleLongIdent ~lowercase p = (* Parser.leaveBreadcrumb p Reporting.ModuleLongIdent; *) let startPos = p.Parser.startPos in - let moduleIdent = match p.Parser.token with - | Lident ident when lowercase -> - let loc = mkLoc startPos p.endPos in - let lident = Longident.Lident ident in - Parser.next p; - Location.mkloc lident loc - | Uident ident -> - let lident = Longident.Lident ident in - let endPos = p.endPos in - Parser.next p; - begin match p.Parser.token with - | Dot -> + let moduleIdent = + match p.Parser.token with + | Lident ident when lowercase -> + let loc = mkLoc startPos p.endPos in + let lident = Longident.Lident ident in Parser.next p; - parseModuleLongIdentTail ~lowercase p startPos lident - | _ -> Location.mkloc lident (mkLoc startPos endPos) - end - | t -> - Parser.err p (Diagnostics.uident t); - Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) + Location.mkloc lident loc + | Uident ident -> ( + let lident = Longident.Lident ident in + let endPos = p.endPos in + Parser.next p; + match p.Parser.token with + | Dot -> + Parser.next p; + parseModuleLongIdentTail ~lowercase p startPos lident + | _ -> Location.mkloc lident (mkLoc startPos endPos)) + | t -> + Parser.err p (Diagnostics.uident t); + Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) in (* Parser.eatBreadcrumb p; *) moduleIdent @@ -813,35 +871,34 @@ let parseModuleLongIdent ~lowercase p = let parseIdentPath p = let rec loop p acc = match p.Parser.token with - | Uident ident | Lident ident -> + | Uident ident | Lident ident -> ( Parser.next p; - let lident = (Longident.Ldot (acc, ident)) in - begin match p.Parser.token with + let lident = Longident.Ldot (acc, ident) in + match p.Parser.token with | Dot -> Parser.next p; loop p lident - | _ -> lident - end + | _ -> lident) | _t -> acc in match p.Parser.token with - | Lident ident | Uident ident -> + | Lident ident | Uident ident -> ( Parser.next p; - begin match p.Parser.token with + match p.Parser.token with | Dot -> Parser.next p; loop p (Longident.Lident ident) - | _ -> Longident.Lident ident - end - | _ -> - Longident.Lident "_" + | _ -> Longident.Lident ident) + | _ -> Longident.Lident "_" let verifyJsxOpeningClosingName p nameExpr = - let closing = match p.Parser.token with - | Lident lident -> Parser.next p; Longident.Lident lident - | Uident _ -> - (parseModuleLongIdent ~lowercase:true p).txt - | _ -> Longident.Lident "" + let closing = + match p.Parser.token with + | Lident lident -> + Parser.next p; + Longident.Lident lident + | Uident _ -> (parseModuleLongIdent ~lowercase:true p).txt + | _ -> Longident.Lident "" in match nameExpr.Parsetree.pexp_desc with | Pexp_ident openingIdent -> @@ -850,7 +907,7 @@ let verifyJsxOpeningClosingName p nameExpr = Longident.flatten openingIdent.txt |> List.filter (fun s -> s <> "createElement") in - match (Longident.unflatten withoutCreateElement) with + match Longident.unflatten withoutCreateElement with | Some li -> li | None -> Longident.Lident "" in @@ -872,10 +929,8 @@ let parseOpenDescription ~attrs p = Parser.leaveBreadcrumb p Grammar.OpenDescription; let startPos = p.Parser.startPos in Parser.expect Open p; - let override = if Parser.optional p Token.Bang then - Asttypes.Override - else - Asttypes.Fresh + let override = + if Parser.optional p Token.Bang then Asttypes.Override else Asttypes.Fresh in let modident = parseModuleLongIdent ~lowercase:false p in let loc = mkLoc startPos p.prevEndPos in @@ -887,13 +942,13 @@ let parseTemplateStringLiteral s = let b = Buffer.create len in let rec loop i = - if i < len then + if i < len then ( let c = String.unsafe_get s i in match c with | '\\' as c -> - if i + 1 < len then + if i + 1 < len then ( let nextChar = String.unsafe_get s (i + 1) in - begin match nextChar with + match nextChar with | '\\' as c -> Buffer.add_char b c; loop (i + 2) @@ -909,54 +964,51 @@ let parseTemplateStringLiteral s = | c -> Buffer.add_char b '\\'; Buffer.add_char b c; - loop (i + 2) - end - else ( - Buffer.add_char b c - ) - + loop (i + 2)) + else Buffer.add_char b c | c -> Buffer.add_char b c; - loop (i + 1) - - else - () + loop (i + 1)) + else () in loop 0; Buffer.contents b (* constant ::= integer-literal *) - (* ∣ float-literal *) - (* ∣ string-literal *) +(* ∣ float-literal *) +(* ∣ string-literal *) let parseConstant p = - let isNegative = match p.Parser.token with - | Token.Minus -> Parser.next p; true - | Plus -> Parser.next p; false - | _ -> false + let isNegative = + match p.Parser.token with + | Token.Minus -> + Parser.next p; + true + | Plus -> + Parser.next p; + false + | _ -> false in - let constant = match p.Parser.token with - | Int {i; suffix} -> - let intTxt = if isNegative then "-" ^ i else i in - Parsetree.Pconst_integer (intTxt, suffix) - | Float {f; suffix} -> - let floatTxt = if isNegative then "-" ^ f else f in - Parsetree.Pconst_float (floatTxt, suffix) - | String s -> - if p.mode = ParseForTypeChecker then - Pconst_string (s, Some "js") - else - Pconst_string (s, None) - | Codepoint {c; original} -> - if p.mode = ParseForTypeChecker then - Pconst_char c - else - (* Pconst_char char does not have enough information for formatting. - * When parsing for the printer, we encode the char contents as a string - * with a special prefix. *) - Pconst_string (original, Some "INTERNAL_RES_CHAR_CONTENTS") - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Pconst_string("", None) + let constant = + match p.Parser.token with + | Int {i; suffix} -> + let intTxt = if isNegative then "-" ^ i else i in + Parsetree.Pconst_integer (intTxt, suffix) + | Float {f; suffix} -> + let floatTxt = if isNegative then "-" ^ f else f in + Parsetree.Pconst_float (floatTxt, suffix) + | String s -> + if p.mode = ParseForTypeChecker then Pconst_string (s, Some "js") + else Pconst_string (s, None) + | Codepoint {c; original} -> + if p.mode = ParseForTypeChecker then Pconst_char c + else + (* Pconst_char char does not have enough information for formatting. + * When parsing for the printer, we encode the char contents as a string + * with a special prefix. *) + Pconst_string (original, Some "INTERNAL_RES_CHAR_CONTENTS") + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Pconst_string ("", None) in Parser.next p; constant @@ -968,16 +1020,20 @@ let parseTemplateConstant ~prefix (p : Parser.t) = match p.token with | TemplateTail txt -> Parser.next p; - let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in + let txt = + if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt + else txt + in Parsetree.Pconst_string (txt, prefix) | _ -> let rec skipTokens () = if p.token <> Eof then ( Parser.next p; match p.token with - | Backtick -> Parser.next p; () - | _ -> skipTokens () - ) + | Backtick -> + Parser.next p; + () + | _ -> skipTokens ()) in skipTokens (); Parser.err ~startPos ~endPos:p.prevEndPos p @@ -988,13 +1044,12 @@ let parseCommaDelimitedRegion p ~grammar ~closing ~f = Parser.leaveBreadcrumb p grammar; let rec loop nodes = match f p with - | Some node -> - begin match p.Parser.token with + | Some node -> ( + match p.Parser.token with | Comma -> Parser.next p; - loop (node::nodes) - | token when token = closing || token = Eof -> - List.rev (node::nodes) + loop (node :: nodes) + | token when token = closing || token = Eof -> List.rev (node :: nodes) | _ when Grammar.isListElement grammar p.token -> (* missing comma between nodes in the region and the current token * looks like the start of something valid in the current region. @@ -1009,21 +1064,22 @@ let parseCommaDelimitedRegion p ~grammar ~closing ~f = * We report the error here and then continue parsing the region. *) Parser.expect Comma p; - loop (node::nodes) + loop (node :: nodes) | _ -> - if not (p.token = Eof || p.token = closing || Recover.shouldAbortListParse p) then - Parser.expect Comma p; + if + not + (p.token = Eof || p.token = closing + || Recover.shouldAbortListParse p) + then Parser.expect Comma p; if p.token = Semicolon then Parser.next p; - loop (node::nodes) - end + loop (node :: nodes)) | None -> - if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p then - List.rev nodes + if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p + then List.rev nodes else ( Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); Parser.next p; - loop nodes - ); + loop nodes) in let nodes = loop [] in Parser.eatBreadcrumb p; @@ -1033,13 +1089,12 @@ let parseCommaDelimitedReversedList p ~grammar ~closing ~f = Parser.leaveBreadcrumb p grammar; let rec loop nodes = match f p with - | Some node -> - begin match p.Parser.token with + | Some node -> ( + match p.Parser.token with | Comma -> Parser.next p; - loop (node::nodes) - | token when token = closing || token = Eof -> - (node::nodes) + loop (node :: nodes) + | token when token = closing || token = Eof -> node :: nodes | _ when Grammar.isListElement grammar p.token -> (* missing comma between nodes in the region and the current token * looks like the start of something valid in the current region. @@ -1054,21 +1109,22 @@ let parseCommaDelimitedReversedList p ~grammar ~closing ~f = * We report the error here and then continue parsing the region. *) Parser.expect Comma p; - loop (node::nodes) + loop (node :: nodes) | _ -> - if not (p.token = Eof || p.token = closing || Recover.shouldAbortListParse p) then - Parser.expect Comma p; + if + not + (p.token = Eof || p.token = closing + || Recover.shouldAbortListParse p) + then Parser.expect Comma p; if p.token = Semicolon then Parser.next p; - loop (node::nodes) - end + loop (node :: nodes)) | None -> - if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p then - nodes + if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p + then nodes else ( Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); Parser.next p; - loop nodes - ); + loop nodes) in let nodes = loop [] in Parser.eatBreadcrumb p; @@ -1078,244 +1134,216 @@ let parseDelimitedRegion p ~grammar ~closing ~f = Parser.leaveBreadcrumb p grammar; let rec loop nodes = match f p with - | Some node -> - loop (node::nodes) + | Some node -> loop (node :: nodes) | None -> - if ( - p.Parser.token = Token.Eof || - p.token = closing || - Recover.shouldAbortListParse p - ) then - List.rev nodes + if + p.Parser.token = Token.Eof || p.token = closing + || Recover.shouldAbortListParse p + then List.rev nodes else ( Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); Parser.next p; - loop nodes - ) - in - let nodes = loop [] in - Parser.eatBreadcrumb p; - nodes + loop nodes) + in + let nodes = loop [] in + Parser.eatBreadcrumb p; + nodes let parseRegion p ~grammar ~f = Parser.leaveBreadcrumb p grammar; let rec loop nodes = match f p with - | Some node -> - loop (node::nodes) + | Some node -> loop (node :: nodes) | None -> if p.Parser.token = Token.Eof || Recover.shouldAbortListParse p then List.rev nodes else ( Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); Parser.next p; - loop nodes - ) + loop nodes) in let nodes = loop [] in Parser.eatBreadcrumb p; nodes (* let-binding ::= pattern = expr *) - (* ∣ value-name { parameter } [: typexpr] [:> typexpr] = expr *) - (* ∣ value-name : poly-typexpr = expr *) - - (* pattern ::= value-name *) - (* ∣ _ *) - (* ∣ constant *) - (* ∣ pattern as value-name *) - (* ∣ ( pattern ) *) - (* ∣ ( pattern : typexpr ) *) - (* ∣ pattern | pattern *) - (* ∣ constr pattern *) - (* ∣ #variant variant-pattern *) - (* ∣ #...type *) - (* ∣ / pattern { , pattern }+ / *) - (* ∣ { field [: typexpr] [= pattern] { ; field [: typexpr] [= pattern] } [; _ ] [ ; ] } *) - (* ∣ [ pattern { ; pattern } [ ; ] ] *) - (* ∣ pattern :: pattern *) - (* ∣ [| pattern { ; pattern } [ ; ] |] *) - (* ∣ char-literal .. char-literal *) - (* ∣ exception pattern *) -let rec parsePattern ?(alias=true) ?(or_=true) p = +(* ∣ value-name { parameter } [: typexpr] [:> typexpr] = expr *) +(* ∣ value-name : poly-typexpr = expr *) + +(* pattern ::= value-name *) +(* ∣ _ *) +(* ∣ constant *) +(* ∣ pattern as value-name *) +(* ∣ ( pattern ) *) +(* ∣ ( pattern : typexpr ) *) +(* ∣ pattern | pattern *) +(* ∣ constr pattern *) +(* ∣ #variant variant-pattern *) +(* ∣ #...type *) +(* ∣ / pattern { , pattern }+ / *) +(* ∣ { field [: typexpr] [= pattern] { ; field [: typexpr] [= pattern] } [; _ ] [ ; ] } *) +(* ∣ [ pattern { ; pattern } [ ; ] ] *) +(* ∣ pattern :: pattern *) +(* ∣ [| pattern { ; pattern } [ ; ] |] *) +(* ∣ char-literal .. char-literal *) +(* ∣ exception pattern *) +let rec parsePattern ?(alias = true) ?(or_ = true) p = let startPos = p.Parser.startPos in let attrs = parseAttributes p in - let pat = match p.Parser.token with - | (True | False) as token -> - let endPos = p.endPos in - Parser.next p; - let loc = mkLoc startPos endPos in - Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident (Token.toString token)) loc) None - | Int _ | String _ | Float _ | Codepoint _ | Minus | Plus -> - let c = parseConstant p in - begin match p.token with + let pat = + match p.Parser.token with + | (True | False) as token -> + let endPos = p.endPos in + Parser.next p; + let loc = mkLoc startPos endPos in + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident (Token.toString token)) loc) + None + | Int _ | String _ | Float _ | Codepoint _ | Minus | Plus -> ( + let c = parseConstant p in + match p.token with | DotDot -> Parser.next p; let c2 = parseConstant p in Ast_helper.Pat.interval ~loc:(mkLoc startPos p.prevEndPos) c c2 - | _ -> - Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) c - end - | Backtick -> - let constant = parseTemplateConstant ~prefix:(Some "js") p in - Ast_helper.Pat.constant ~attrs:[templateLiteralAttr] ~loc:(mkLoc startPos p.prevEndPos) constant - | Lparen -> - Parser.next p; - begin match p.token with - | Rparen -> + | _ -> Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) c) + | Backtick -> + let constant = parseTemplateConstant ~prefix:(Some "js") p in + Ast_helper.Pat.constant ~attrs:[templateLiteralAttr] + ~loc:(mkLoc startPos p.prevEndPos) + constant + | Lparen -> ( Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct ~loc lid None - | _ -> - let pat = parseConstrainedPattern p in - begin match p.token with - | Comma -> + match p.token with + | Rparen -> Parser.next p; - parseTuplePattern ~attrs ~first:pat ~startPos p - | _ -> - Parser.expect Rparen p; let loc = mkLoc startPos p.prevEndPos in - {pat with ppat_loc = loc} - end - end - | Lbracket -> - parseArrayPattern ~attrs p - | Lbrace -> - parseRecordPattern ~attrs p - | Underscore -> - let endPos = p.endPos in - let loc = mkLoc startPos endPos in - Parser.next p; - Ast_helper.Pat.any ~loc ~attrs () - | Lident ident -> - let endPos = p.endPos in - let loc = mkLoc startPos endPos in - Parser.next p; - begin match p.token with - | Backtick -> - let constant = parseTemplateConstant ~prefix:(Some ident) p in - Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) constant - | _ -> - Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc) - end - | Uident _ -> - let constr = parseModuleLongIdent ~lowercase:false p in - begin match p.Parser.token with - | Lparen -> - parseConstructorPatternArgs p constr startPos attrs - | _ -> - Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr None - end - | Hash -> - Parser.next p; - if p.Parser.token == DotDotDot then ( + let lid = Location.mkloc (Longident.Lident "()") loc in + Ast_helper.Pat.construct ~loc lid None + | _ -> ( + let pat = parseConstrainedPattern p in + match p.token with + | Comma -> + Parser.next p; + parseTuplePattern ~attrs ~first:pat ~startPos p + | _ -> + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + {pat with ppat_loc = loc})) + | Lbracket -> parseArrayPattern ~attrs p + | Lbrace -> parseRecordPattern ~attrs p + | Underscore -> + let endPos = p.endPos in + let loc = mkLoc startPos endPos in + Parser.next p; + Ast_helper.Pat.any ~loc ~attrs () + | Lident ident -> ( + let endPos = p.endPos in + let loc = mkLoc startPos endPos in + Parser.next p; + match p.token with + | Backtick -> + let constant = parseTemplateConstant ~prefix:(Some ident) p in + Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) constant + | _ -> Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc)) + | Uident _ -> ( + let constr = parseModuleLongIdent ~lowercase:false p in + match p.Parser.token with + | Lparen -> parseConstructorPatternArgs p constr startPos attrs + | _ -> Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr None) + | Hash -> ( Parser.next p; - let ident = parseValuePath p in - let loc = mkLoc startPos ident.loc.loc_end in - Ast_helper.Pat.type_ ~loc ~attrs ident - ) else ( - let (ident, loc) = match p.token with - | String text -> - let text = if p.mode = ParseForTypeChecker then parseStringLiteral text else text in + if p.Parser.token == DotDotDot then ( Parser.next p; - (text, mkLoc startPos p.prevEndPos) - | Int {i; suffix} -> - let () = match suffix with - | Some _ -> - Parser.err p (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) - | None -> () + let ident = parseValuePath p in + let loc = mkLoc startPos ident.loc.loc_end in + Ast_helper.Pat.type_ ~loc ~attrs ident) + else + let ident, loc = + match p.token with + | String text -> + let text = + if p.mode = ParseForTypeChecker then parseStringLiteral text + else text + in + Parser.next p; + (text, mkLoc startPos p.prevEndPos) + | Int {i; suffix} -> + let () = + match suffix with + | Some _ -> + Parser.err p + (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) + | None -> () + in + Parser.next p; + (i, mkLoc startPos p.prevEndPos) + | _ -> parseIdent ~msg:ErrorMessages.variantIdent ~startPos p in - Parser.next p; - (i, mkLoc startPos p.prevEndPos) - | _ -> - parseIdent ~msg:ErrorMessages.variantIdent ~startPos p - in - begin match p.Parser.token with - | Lparen -> - parseVariantPatternArgs p ident startPos attrs - | _ -> - Ast_helper.Pat.variant ~loc ~attrs ident None - end - ) - | Exception -> - Parser.next p; - let pat = parsePattern ~alias:false ~or_:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.exception_ ~loc ~attrs pat - | Lazy -> - Parser.next p; - let pat = parsePattern ~alias:false ~or_:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.lazy_ ~loc ~attrs pat - | List -> - Parser.next p; - parseListPattern ~startPos ~attrs p - | Module -> - parseModulePattern ~attrs p - | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.extension ~loc ~attrs extension - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - begin match skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicPatternStart with - | None -> - Recover.defaultPattern() - | Some () -> - parsePattern p - end + match p.Parser.token with + | Lparen -> parseVariantPatternArgs p ident startPos attrs + | _ -> Ast_helper.Pat.variant ~loc ~attrs ident None) + | Exception -> + Parser.next p; + let pat = parsePattern ~alias:false ~or_:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.exception_ ~loc ~attrs pat + | Lazy -> + Parser.next p; + let pat = parsePattern ~alias:false ~or_:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.lazy_ ~loc ~attrs pat + | List -> + Parser.next p; + parseListPattern ~startPos ~attrs p + | Module -> parseModulePattern ~attrs p + | Percent -> + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.extension ~loc ~attrs extension + | token -> ( + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + match + skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicPatternStart + with + | None -> Recover.defaultPattern () + | Some () -> parsePattern p) in let pat = if alias then parseAliasPattern ~attrs pat p else pat in if or_ then parseOrPattern pat p else pat and skipTokensAndMaybeRetry p ~isStartOfGrammar = - if Token.isKeyword p.Parser.token - && p.Parser.prevEndPos.pos_lnum == p.startPos.pos_lnum + if + Token.isKeyword p.Parser.token + && p.Parser.prevEndPos.pos_lnum == p.startPos.pos_lnum then ( Parser.next p; - None - ) else ( - if Recover.shouldAbortListParse p then - begin - if isStartOfGrammar p.Parser.token then - begin - Parser.next p; - Some () - end - else - None - end - else - begin + None) + else if Recover.shouldAbortListParse p then + if isStartOfGrammar p.Parser.token then ( + Parser.next p; + Some ()) + else None + else ( + Parser.next p; + let rec loop p = + if not (Recover.shouldAbortListParse p) then ( Parser.next p; - let rec loop p = - if not (Recover.shouldAbortListParse p) - then begin - Parser.next p; - loop p - end in - loop p; - if isStartOfGrammar p.Parser.token then - Some () - else - None - end - ) + loop p) + in + loop p; + if isStartOfGrammar p.Parser.token then Some () else None) (* alias ::= pattern as lident *) and parseAliasPattern ~attrs pattern p = match p.Parser.token with | As -> Parser.next p; - let (name, loc) = parseLident p in + let name, loc = parseLident p in let name = Location.mkloc name loc in Ast_helper.Pat.alias - ~loc:({pattern.ppat_loc with loc_end = p.prevEndPos}) - ~attrs - pattern - name + ~loc:{pattern.ppat_loc with loc_end = p.prevEndPos} + ~attrs pattern name | _ -> pattern (* or ::= pattern | pattern @@ -1326,32 +1354,32 @@ and parseOrPattern pattern1 p = | Bar -> Parser.next p; let pattern2 = parsePattern ~or_:false p in - let loc = { pattern1.Parsetree.ppat_loc with - loc_end = pattern2.ppat_loc.loc_end - } in + let loc = + {pattern1.Parsetree.ppat_loc with loc_end = pattern2.ppat_loc.loc_end} + in loop (Ast_helper.Pat.or_ ~loc pattern1 pattern2) | _ -> pattern1 in loop pattern1 and parseNonSpreadPattern ~msg p = - let () = match p.Parser.token with - | DotDotDot -> - Parser.err p (Diagnostics.message msg); - Parser.next p; - | _ -> () + let () = + match p.Parser.token with + | DotDotDot -> + Parser.err p (Diagnostics.message msg); + Parser.next p + | _ -> () in match p.Parser.token with - | token when Grammar.isPatternStart token -> + | token when Grammar.isPatternStart token -> ( let pat = parsePattern p in - begin match p.Parser.token with + match p.Parser.token with | Colon -> Parser.next p; let typ = parseTypExpr p in let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in Some (Ast_helper.Pat.constraint_ ~loc pat typ) - | _ -> Some pat - end + | _ -> Some pat) | _ -> None and parseConstrainedPattern p = @@ -1366,8 +1394,7 @@ and parseConstrainedPattern p = and parseConstrainedPatternRegion p = match p.Parser.token with - | token when Grammar.isPatternStart token -> - Some (parseConstrainedPattern p) + | token when Grammar.isPatternStart token -> Some (parseConstrainedPattern p) | _ -> None (* field ::= @@ -1382,82 +1409,75 @@ and parseConstrainedPatternRegion p = *) and parseRecordPatternField p = let label = parseValuePath p in - let pattern = match p.Parser.token with - | Colon -> - Parser.next p; - parsePattern p - | _ -> - Ast_helper.Pat.var - ~loc:label.loc - (Location.mkloc (Longident.last label.txt) label.loc) + let pattern = + match p.Parser.token with + | Colon -> + Parser.next p; + parsePattern p + | _ -> + Ast_helper.Pat.var ~loc:label.loc + (Location.mkloc (Longident.last label.txt) label.loc) in (label, pattern) - (* TODO: there are better representations than PatField|Underscore ? *) +(* TODO: there are better representations than PatField|Underscore ? *) and parseRecordPatternItem p = match p.Parser.token with | DotDotDot -> Parser.next p; Some (true, PatField (parseRecordPatternField p)) - | Uident _ | Lident _ -> - Some (false, PatField (parseRecordPatternField p)) + | Uident _ | Lident _ -> Some (false, PatField (parseRecordPatternField p)) | Underscore -> Parser.next p; Some (false, PatUnderscore) - | _ -> - None + | _ -> None and parseRecordPattern ~attrs p = let startPos = p.startPos in Parser.expect Lbrace p; let rawFields = - parseCommaDelimitedReversedList p - ~grammar:PatternRecord - ~closing:Rbrace - ~f:parseRecordPatternItem + parseCommaDelimitedReversedList p ~grammar:PatternRecord ~closing:Rbrace + ~f:parseRecordPatternItem in Parser.expect Rbrace p; - let (fields, closedFlag) = - let (rawFields, flag) = match rawFields with - | (_hasSpread, PatUnderscore)::rest -> - (rest, Asttypes.Open) - | rawFields -> - (rawFields, Asttypes.Closed) + let fields, closedFlag = + let rawFields, flag = + match rawFields with + | (_hasSpread, PatUnderscore) :: rest -> (rest, Asttypes.Open) + | rawFields -> (rawFields, Asttypes.Closed) in - List.fold_left (fun (fields, flag) curr -> - let (hasSpread, field) = curr in - match field with - | PatField field -> - if hasSpread then ( - let (_, pattern) = field in - Parser.err ~startPos:pattern.Parsetree.ppat_loc.loc_start p (Diagnostics.message ErrorMessages.recordPatternSpread) - ); - (field::fields, flag) - | PatUnderscore -> - (fields, flag) - ) ([], flag) rawFields + List.fold_left + (fun (fields, flag) curr -> + let hasSpread, field = curr in + match field with + | PatField field -> + (if hasSpread then + let _, pattern = field in + Parser.err ~startPos:pattern.Parsetree.ppat_loc.loc_start p + (Diagnostics.message ErrorMessages.recordPatternSpread)); + (field :: fields, flag) + | PatUnderscore -> (fields, flag)) + ([], flag) rawFields in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Pat.record ~loc ~attrs fields closedFlag and parseTuplePattern ~attrs ~first ~startPos p = let patterns = - first::( - parseCommaDelimitedRegion p - ~grammar:Grammar.PatternList - ~closing:Rparen - ~f:parseConstrainedPatternRegion - ) + first + :: parseCommaDelimitedRegion p ~grammar:Grammar.PatternList ~closing:Rparen + ~f:parseConstrainedPatternRegion in Parser.expect Rparen p; - let () = match patterns with - | [_] -> - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.tupleSingleElement) - | _ -> () + let () = + match patterns with + | [_] -> + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.tupleSingleElement) + | _ -> () in let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.tuple ~loc ~attrs (patterns) + Ast_helper.Pat.tuple ~loc ~attrs patterns and parsePatternRegion p = match p.Parser.token with @@ -1472,71 +1492,62 @@ and parseModulePattern ~attrs p = let startPos = p.Parser.startPos in Parser.expect Module p; Parser.expect Lparen p; - let uident = match p.token with - | Uident uident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc uident loc - | _ -> (* TODO: error recovery *) - Location.mknoloc "_" + let uident = + match p.token with + | Uident uident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc uident loc + | _ -> + (* TODO: error recovery *) + Location.mknoloc "_" in - begin match p.token with + match p.token with | Colon -> let colonStart = p.Parser.startPos in Parser.next p; let packageTypAttrs = parseAttributes p in - let packageType = parsePackageType ~startPos:colonStart ~attrs:packageTypAttrs p in + let packageType = + parsePackageType ~startPos:colonStart ~attrs:packageTypAttrs p + in Parser.expect Rparen p; let loc = mkLoc startPos p.prevEndPos in let unpack = Ast_helper.Pat.unpack ~loc:uident.loc uident in - Ast_helper.Pat.constraint_ - ~loc - ~attrs - unpack - packageType + Ast_helper.Pat.constraint_ ~loc ~attrs unpack packageType | _ -> Parser.expect Rparen p; let loc = mkLoc startPos p.prevEndPos in Ast_helper.Pat.unpack ~loc ~attrs uident - end and parseListPattern ~startPos ~attrs p = let listPatterns = - parseCommaDelimitedReversedList p - ~grammar:Grammar.PatternOcamlList - ~closing:Rbrace - ~f:parsePatternRegion + parseCommaDelimitedReversedList p ~grammar:Grammar.PatternOcamlList + ~closing:Rbrace ~f:parsePatternRegion in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in let filterSpread (hasSpread, pattern) = if hasSpread then ( - Parser.err - ~startPos:pattern.Parsetree.ppat_loc.loc_start - p + Parser.err ~startPos:pattern.Parsetree.ppat_loc.loc_start p (Diagnostics.message ErrorMessages.listPatternSpread); - pattern - ) else - pattern + pattern) + else pattern in match listPatterns with - | (true, pattern)::patterns -> + | (true, pattern) :: patterns -> let patterns = patterns |> List.map filterSpread |> List.rev in let pat = makeListPattern loc patterns (Some pattern) in - {pat with ppat_loc = loc; ppat_attributes = attrs;} + {pat with ppat_loc = loc; ppat_attributes = attrs} | patterns -> let patterns = patterns |> List.map filterSpread |> List.rev in let pat = makeListPattern loc patterns None in - {pat with ppat_loc = loc; ppat_attributes = attrs;} + {pat with ppat_loc = loc; ppat_attributes = attrs} and parseArrayPattern ~attrs p = let startPos = p.startPos in Parser.expect Lbracket p; let patterns = - parseCommaDelimitedRegion - p - ~grammar:Grammar.PatternList - ~closing:Rbracket + parseCommaDelimitedRegion p ~grammar:Grammar.PatternList ~closing:Rbracket ~f:(parseNonSpreadPattern ~msg:ErrorMessages.arrayPatternSpread) in Parser.expect Rbracket p; @@ -1546,26 +1557,29 @@ and parseArrayPattern ~attrs p = and parseConstructorPatternArgs p constr startPos attrs = let lparen = p.startPos in Parser.expect Lparen p; - let args = parseCommaDelimitedRegion - p ~grammar:Grammar.PatternList ~closing:Rparen ~f:parseConstrainedPatternRegion + let args = + parseCommaDelimitedRegion p ~grammar:Grammar.PatternList ~closing:Rparen + ~f:parseConstrainedPatternRegion in Parser.expect Rparen p; - let args = match args with - | [] -> - let loc = mkLoc lparen p.prevEndPos in - Some ( - Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None - ) - | [{ppat_desc = Ppat_tuple _} as pat] as patterns -> - if p.mode = ParseForTypeChecker then - (* Some(1, 2) for type-checker *) - Some pat - else - (* Some((1, 2)) for printer *) + let args = + match args with + | [] -> + let loc = mkLoc lparen p.prevEndPos in + Some + (Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None) + | [({ppat_desc = Ppat_tuple _} as pat)] as patterns -> + if p.mode = ParseForTypeChecker then + (* Some(1, 2) for type-checker *) + Some pat + else + (* Some((1, 2)) for printer *) + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + | [pattern] -> Some pattern + | patterns -> Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) - | [pattern] -> Some pattern - | patterns -> - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) in Ast_helper.Pat.construct ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args @@ -1573,16 +1587,18 @@ and parseVariantPatternArgs p ident startPos attrs = let lparen = p.startPos in Parser.expect Lparen p; let patterns = - parseCommaDelimitedRegion - p ~grammar:Grammar.PatternList ~closing:Rparen ~f:parseConstrainedPatternRegion in + parseCommaDelimitedRegion p ~grammar:Grammar.PatternList ~closing:Rparen + ~f:parseConstrainedPatternRegion + in let args = match patterns with | [] -> let loc = mkLoc lparen p.prevEndPos in - Some ( - Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None - ) - | [{ppat_desc = Ppat_tuple _} as pat] as patterns -> + Some + (Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None) + | [({ppat_desc = Ppat_tuple _} as pat)] as patterns -> if p.mode = ParseForTypeChecker then (* #ident(1, 2) for type-checker *) Some pat @@ -1596,7 +1612,7 @@ and parseVariantPatternArgs p ident startPos attrs = Parser.expect Rparen p; Ast_helper.Pat.variant ~loc:(mkLoc startPos p.prevEndPos) ~attrs ident args -and parseExpr ?(context=OrdinaryExpr) p = +and parseExpr ?(context = OrdinaryExpr) p = let expr = parseOperandExpr ~context p in let expr = parseBinaryExpr ~context ~a:expr p 1 in parseTernaryExpr expr p @@ -1611,29 +1627,31 @@ and parseTernaryExpr leftOperand p = Parser.expect Colon p; let falseBranch = parseExpr p in Parser.eatBreadcrumb p; - let loc = {leftOperand.Parsetree.pexp_loc with - loc_start = leftOperand.pexp_loc.loc_start; - loc_end = falseBranch.Parsetree.pexp_loc.loc_end; - } in - Ast_helper.Exp.ifthenelse - ~attrs:[ternaryAttr] ~loc - leftOperand trueBranch (Some falseBranch) - | _ -> - leftOperand + let loc = + { + leftOperand.Parsetree.pexp_loc with + loc_start = leftOperand.pexp_loc.loc_start; + loc_end = falseBranch.Parsetree.pexp_loc.loc_end; + } + in + Ast_helper.Exp.ifthenelse ~attrs:[ternaryAttr] ~loc leftOperand trueBranch + (Some falseBranch) + | _ -> leftOperand and parseEs6ArrowExpression ?context ?parameters p = let startPos = p.Parser.startPos in Parser.leaveBreadcrumb p Grammar.Es6ArrowExpr; - let parameters = match parameters with - | Some params -> params - | None -> parseParameters p + let parameters = + match parameters with + | Some params -> params + | None -> parseParameters p in - let returnType = match p.Parser.token with - | Colon -> - Parser.next p; - Some (parseTypExpr ~es6Arrow:false p) - | _ -> - None + let returnType = + match p.Parser.token with + | Colon -> + Parser.next p; + Some (parseTypExpr ~es6Arrow:false p) + | _ -> None in Parser.expect EqualGreater p; let body = @@ -1641,21 +1659,32 @@ and parseEs6ArrowExpression ?context ?parameters p = match returnType with | Some typ -> Ast_helper.Exp.constraint_ - ~loc:(mkLoc expr.pexp_loc.loc_start typ.Parsetree.ptyp_loc.loc_end) expr typ + ~loc:(mkLoc expr.pexp_loc.loc_start typ.Parsetree.ptyp_loc.loc_end) + expr typ | None -> expr in Parser.eatBreadcrumb p; let endPos = p.prevEndPos in let arrowExpr = - List.fold_right (fun parameter expr -> - match parameter with - | TermParameter {uncurried; attrs; label = lbl; expr = defaultExpr; pat; pos = startPos} -> - let attrs = if uncurried then uncurryAttr::attrs else attrs in - Ast_helper.Exp.fun_ ~loc:(mkLoc startPos endPos) ~attrs lbl defaultExpr pat expr - | TypeParameter {uncurried; attrs; locs = newtypes; pos = startPos} -> - let attrs = if uncurried then uncurryAttr::attrs else attrs in - makeNewtypes ~attrs ~loc:(mkLoc startPos endPos) newtypes expr - ) parameters body + List.fold_right + (fun parameter expr -> + match parameter with + | TermParameter + { + uncurried; + attrs; + label = lbl; + expr = defaultExpr; + pat; + pos = startPos; + } -> + let attrs = if uncurried then uncurryAttr :: attrs else attrs in + Ast_helper.Exp.fun_ ~loc:(mkLoc startPos endPos) ~attrs lbl + defaultExpr pat expr + | TypeParameter {uncurried; attrs; locs = newtypes; pos = startPos} -> + let attrs = if uncurried then uncurryAttr :: attrs else attrs in + makeNewtypes ~attrs ~loc:(mkLoc startPos endPos) newtypes expr) + parameters body in {arrowExpr with pexp_loc = {arrowExpr.pexp_loc with loc_start = startPos}} @@ -1679,12 +1708,10 @@ and parseEs6ArrowExpression ?context ?parameters p = * labelName ::= lident *) and parseParameter p = - if ( - p.Parser.token = Token.Typ || - p.token = Tilde || - p.token = Dot || - Grammar.isPatternStart p.token - ) then ( + if + p.Parser.token = Token.Typ || p.token = Tilde || p.token = Dot + || Grammar.isPatternStart p.token + then let startPos = p.Parser.startPos in let uncurried = Parser.optional p Token.Dot in (* two scenarios: @@ -1692,90 +1719,103 @@ and parseParameter p = * attrs pattern * Attributes before a labelled arg, indicate that it's on the whole arrow expr * Otherwise it's part of the pattern - * *) + * *) let attrs = parseAttributes p in if p.Parser.token = Typ then ( Parser.next p; let lidents = parseLidentList p in - Some (TypeParameter {uncurried; attrs; locs = lidents; pos = startPos}) - ) else ( - let (attrs, lbl, pat) = match p.Parser.token with - | Tilde -> - Parser.next p; - let (lblName, loc) = parseLident p in - let propLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in - begin match p.Parser.token with - | Comma | Equal | Rparen -> - let loc = mkLoc startPos p.prevEndPos in - ( - attrs, - Asttypes.Labelled lblName, - Ast_helper.Pat.var ~attrs:[propLocAttr] ~loc (Location.mkloc lblName loc) - ) - | Colon -> - let lblEnd = p.prevEndPos in - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos lblEnd in - let pat = - let pat = Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.constraint_ ~attrs:[propLocAttr] ~loc pat typ in - (attrs, Asttypes.Labelled lblName, pat) - | As -> - Parser.next p; - let pat = - let pat = parseConstrainedPattern p in - {pat with ppat_attributes = propLocAttr::pat.ppat_attributes} - in - (attrs, Asttypes.Labelled lblName, pat) - | t -> - Parser.err p (Diagnostics.unexpected t p.breadcrumbs); - let loc = mkLoc startPos p.prevEndPos in - ( - attrs, - Asttypes.Labelled lblName, - Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) - ) - end - | _ -> - let pattern = parseConstrainedPattern p in - let attrs = List.concat [attrs; pattern.ppat_attributes] in - ([], Asttypes.Nolabel, {pattern with ppat_attributes = attrs}) - in - match p.Parser.token with - | Equal -> - Parser.next p; - let lbl = match lbl with - | Asttypes.Labelled lblName -> Asttypes.Optional lblName - | Asttypes.Nolabel -> - let lblName = match pat.ppat_desc with | Ppat_var var -> var.txt | _ -> "" in - Parser.err ~startPos ~endPos:p.prevEndPos p ( - Diagnostics.message (ErrorMessages.missingTildeLabeledParameter lblName) - ); - Asttypes.Optional lblName - | lbl -> lbl + Some (TypeParameter {uncurried; attrs; locs = lidents; pos = startPos})) + else + let attrs, lbl, pat = + match p.Parser.token with + | Tilde -> ( + Parser.next p; + let lblName, loc = parseLident p in + let propLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + in + match p.Parser.token with + | Comma | Equal | Rparen -> + let loc = mkLoc startPos p.prevEndPos in + ( attrs, + Asttypes.Labelled lblName, + Ast_helper.Pat.var ~attrs:[propLocAttr] ~loc + (Location.mkloc lblName loc) ) + | Colon -> + let lblEnd = p.prevEndPos in + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc startPos lblEnd in + let pat = + let pat = Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.constraint_ ~attrs:[propLocAttr] ~loc pat typ + in + (attrs, Asttypes.Labelled lblName, pat) + | As -> + Parser.next p; + let pat = + let pat = parseConstrainedPattern p in + {pat with ppat_attributes = propLocAttr :: pat.ppat_attributes} + in + (attrs, Asttypes.Labelled lblName, pat) + | t -> + Parser.err p (Diagnostics.unexpected t p.breadcrumbs); + let loc = mkLoc startPos p.prevEndPos in + ( attrs, + Asttypes.Labelled lblName, + Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) )) + | _ -> + let pattern = parseConstrainedPattern p in + let attrs = List.concat [attrs; pattern.ppat_attributes] in + ([], Asttypes.Nolabel, {pattern with ppat_attributes = attrs}) in - begin match p.Parser.token with - | Question -> + match p.Parser.token with + | Equal -> ( Parser.next p; - Some (TermParameter {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) + let lbl = + match lbl with + | Asttypes.Labelled lblName -> Asttypes.Optional lblName + | Asttypes.Nolabel -> + let lblName = + match pat.ppat_desc with + | Ppat_var var -> var.txt + | _ -> "" + in + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message + (ErrorMessages.missingTildeLabeledParameter lblName)); + Asttypes.Optional lblName + | lbl -> lbl + in + match p.Parser.token with + | Question -> + Parser.next p; + Some + (TermParameter + {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) + | _ -> + let expr = parseConstrainedOrCoercedExpr p in + Some + (TermParameter + { + uncurried; + attrs; + label = lbl; + expr = Some expr; + pat; + pos = startPos; + })) | _ -> - let expr = parseConstrainedOrCoercedExpr p in - Some (TermParameter {uncurried; attrs; label = lbl; expr = Some expr; pat; pos = startPos}) - end - | _ -> - Some (TermParameter {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) - ) - ) else None + Some + (TermParameter + {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) + else None and parseParameterList p = let parameters = - parseCommaDelimitedRegion - ~grammar:Grammar.ParameterList - ~f:parseParameter - ~closing:Rparen - p + parseCommaDelimitedRegion ~grammar:Grammar.ParameterList ~f:parseParameter + ~closing:Rparen p in Parser.expect Rparen p; parameters @@ -1793,52 +1833,103 @@ and parseParameters p = | Lident ident -> Parser.next p; let loc = mkLoc startPos p.Parser.prevEndPos in - [TermParameter { - uncurried = false; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = Ast_helper.Pat.var ~loc (Location.mkloc ident loc); - pos = startPos; - }] + [ + TermParameter + { + uncurried = false; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = Ast_helper.Pat.var ~loc (Location.mkloc ident loc); + pos = startPos; + }; + ] | Underscore -> Parser.next p; let loc = mkLoc startPos p.Parser.prevEndPos in - [TermParameter {uncurried = false; attrs = []; label = Asttypes.Nolabel; expr = None; pat = Ast_helper.Pat.any ~loc (); pos = startPos}] - | Lparen -> + [ + TermParameter + { + uncurried = false; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = Ast_helper.Pat.any ~loc (); + pos = startPos; + }; + ] + | Lparen -> ( Parser.next p; - begin match p.Parser.token with + match p.Parser.token with | Rparen -> Parser.next p; let loc = mkLoc startPos p.Parser.prevEndPos in - let unitPattern = Ast_helper.Pat.construct - ~loc (Location.mkloc (Longident.Lident "()") loc) None + let unitPattern = + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None in - [TermParameter {uncurried = false; attrs = []; label = Asttypes.Nolabel; expr = None; pat = unitPattern; pos = startPos}] - | Dot -> + [ + TermParameter + { + uncurried = false; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = unitPattern; + pos = startPos; + }; + ] + | Dot -> ( Parser.next p; - begin match p.token with + match p.token with | Rparen -> Parser.next p; let loc = mkLoc startPos p.Parser.prevEndPos in - let unitPattern = Ast_helper.Pat.construct - ~loc (Location.mkloc (Longident.Lident "()") loc) None + let unitPattern = + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None in - [TermParameter {uncurried = true; attrs = []; label = Asttypes.Nolabel; expr = None; pat = unitPattern; pos = startPos}] - | _ -> - begin match parseParameterList p with - | (TermParameter {attrs; label = lbl; expr = defaultExpr; pat = pattern; pos = startPos})::rest -> - (TermParameter {uncurried = true; attrs; label = lbl; expr = defaultExpr; pat = pattern; pos = startPos})::rest - | parameters -> parameters - end - end - | _ -> parseParameterList p - end + [ + TermParameter + { + uncurried = true; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = unitPattern; + pos = startPos; + }; + ] + | _ -> ( + match parseParameterList p with + | TermParameter + { + attrs; + label = lbl; + expr = defaultExpr; + pat = pattern; + pos = startPos; + } + :: rest -> + TermParameter + { + uncurried = true; + attrs; + label = lbl; + expr = defaultExpr; + pat = pattern; + pos = startPos; + } + :: rest + | parameters -> parameters)) + | _ -> parseParameterList p) | token -> Parser.err p (Diagnostics.unexpected token p.breadcrumbs); [] -and parseCoercedExpr ~(expr: Parsetree.expression) p = +and parseCoercedExpr ~(expr : Parsetree.expression) p = Parser.expect ColonGreaterThan p; let typ = parseTypExpr p in let loc = mkLoc expr.pexp_loc.loc_start p.prevEndPos in @@ -1847,37 +1938,30 @@ and parseCoercedExpr ~(expr: Parsetree.expression) p = and parseConstrainedOrCoercedExpr p = let expr = parseExpr p in match p.Parser.token with - | ColonGreaterThan -> - parseCoercedExpr ~expr p - | Colon -> + | ColonGreaterThan -> parseCoercedExpr ~expr p + | Colon -> ( Parser.next p; - begin match p.token with - | _ -> + match p.token with + | _ -> ( let typ = parseTypExpr p in let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in let expr = Ast_helper.Exp.constraint_ ~loc expr typ in - begin match p.token with - | ColonGreaterThan -> - parseCoercedExpr ~expr p - | _ -> - expr - end - end + match p.token with + | ColonGreaterThan -> parseCoercedExpr ~expr p + | _ -> expr)) | _ -> expr - and parseConstrainedExprRegion p = match p.Parser.token with - | token when Grammar.isExprStart token -> + | token when Grammar.isExprStart token -> ( let expr = parseExpr p in - begin match p.Parser.token with + match p.Parser.token with | Colon -> Parser.next p; let typ = parseTypExpr p in let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in Some (Ast_helper.Exp.constraint_ ~loc expr typ) - | _ -> Some expr - end + | _ -> Some expr) | _ -> None (* Atomic expressions represent unambiguous expressions. @@ -1886,12 +1970,14 @@ and parseConstrainedExprRegion p = and parseAtomicExpr p = Parser.leaveBreadcrumb p Grammar.ExprOperand; let startPos = p.Parser.startPos in - let expr = match p.Parser.token with + let expr = + match p.Parser.token with | (True | False) as token -> Parser.next p; let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident (Token.toString token)) loc) None + (Location.mkloc (Longident.Lident (Token.toString token)) loc) + None | Int _ | String _ | Float _ | Codepoint _ -> let c = parseConstant p in let loc = mkLoc startPos p.prevEndPos in @@ -1899,47 +1985,41 @@ and parseAtomicExpr p = | Backtick -> let expr = parseTemplateExpr p in {expr with pexp_loc = mkLoc startPos p.prevEndPos} - | Uident _ | Lident _ -> - parseValueOrConstructor p - | Hash -> - parsePolyVariantExpr p - | Lparen -> + | Uident _ | Lident _ -> parseValueOrConstructor p + | Hash -> parsePolyVariantExpr p + | Lparen -> ( Parser.next p; - begin match p.Parser.token with + match p.Parser.token with | Rparen -> Parser.next p; let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.construct - ~loc (Location.mkloc (Longident.Lident "()") loc) None - | _t -> + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None + | _t -> ( let expr = parseConstrainedOrCoercedExpr p in - begin match p.token with + match p.token with | Comma -> Parser.next p; parseTupleExpr ~startPos ~first:expr p | _ -> Parser.expect Rparen p; expr - (* {expr with pexp_loc = mkLoc startPos p.prevEndPos} - * What does this location mean here? It means that when there's - * a parenthesized we keep the location here for whitespace interleaving. - * Without the closing paren in the location there will always be an extra - * line. For now we don't include it, because it does weird things - * with for comments. *) - end - end + (* {expr with pexp_loc = mkLoc startPos p.prevEndPos} + * What does this location mean here? It means that when there's + * a parenthesized we keep the location here for whitespace interleaving. + * Without the closing paren in the location there will always be an extra + * line. For now we don't include it, because it does weird things + * with for comments. *))) | List -> Parser.next p; - parseListExpr ~startPos p + parseListExpr ~startPos p | Module -> Parser.next p; parseFirstClassModuleExpr ~startPos p - | Lbracket -> - parseArrayExp p - | Lbrace -> - parseBracedOrRecordExpr p - | LessThan -> - parseJsx p + | Lbracket -> parseArrayExp p + | Lbrace -> parseBracedOrRecordExpr p + | LessThan -> parseJsx p | Percent -> let extension = parseExtension p in let loc = mkLoc startPos p.prevEndPos in @@ -1949,13 +2029,14 @@ and parseAtomicExpr p = Parser.err p (Diagnostics.lident token); Parser.next p; Recover.defaultExpr () - | token -> + | token -> ( let errPos = p.prevEndPos in Parser.err ~startPos:errPos p (Diagnostics.unexpected token p.breadcrumbs); - begin match skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicExprStart with - | None -> Recover.defaultExpr() - | Some () -> parseAtomicExpr p - end + match + skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicExprStart + with + | None -> Recover.defaultExpr () + | Some () -> parseAtomicExpr p) in Parser.eatBreadcrumb p; expr @@ -1967,7 +2048,7 @@ and parseFirstClassModuleExpr ~startPos p = let modExpr = parseModuleExpr p in let modEndLoc = p.prevEndPos in - begin match p.Parser.token with + match p.Parser.token with | Colon -> let colonStart = p.Parser.startPos in Parser.next p; @@ -1982,7 +2063,6 @@ and parseFirstClassModuleExpr ~startPos p = Parser.expect Rparen p; let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.pack ~loc modExpr - end and parseBracketAccess p expr startPos = Parser.leaveBreadcrumb p Grammar.ExprArrayAccess; @@ -1990,7 +2070,7 @@ and parseBracketAccess p expr startPos = Parser.next p; let stringStart = p.startPos in match p.Parser.token with - | String s -> + | String s -> ( let s = if p.mode = ParseForTypeChecker then parseStringLiteral s else s in Parser.next p; let stringEnd = p.prevEndPos in @@ -2004,7 +2084,7 @@ and parseBracketAccess p expr startPos = in let e = parsePrimaryExpr ~operand:e p in let equalStart = p.startPos in - begin match p.token with + match p.token with | Equal -> Parser.next p; let equalEnd = p.prevEndPos in @@ -2012,46 +2092,41 @@ and parseBracketAccess p expr startPos = let loc = mkLoc startPos rhsExpr.pexp_loc.loc_end in let operatorLoc = mkLoc equalStart equalEnd in Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc:operatorLoc (Location.mkloc (Longident.Lident "#=") operatorLoc)) - [Nolabel, e; Nolabel, rhsExpr] - | _ -> e - end - | _ -> + (Ast_helper.Exp.ident ~loc:operatorLoc + (Location.mkloc (Longident.Lident "#=") operatorLoc)) + [(Nolabel, e); (Nolabel, rhsExpr)] + | _ -> e) + | _ -> ( let accessExpr = parseConstrainedOrCoercedExpr p in Parser.expect Rbracket p; Parser.eatBreadcrumb p; let rbracket = p.prevEndPos in let arrayLoc = mkLoc lbracket rbracket in - begin match p.token with + match p.token with | Equal -> Parser.leaveBreadcrumb p ExprArrayMutation; Parser.next p; let rhsExpr = parseExpr p in - let arraySet = Location.mkloc - (Longident.Ldot(Lident "Array", "set")) - arrayLoc + let arraySet = + Location.mkloc (Longident.Ldot (Lident "Array", "set")) arrayLoc in let endPos = p.prevEndPos in - let arraySet = Ast_helper.Exp.apply - ~loc:(mkLoc startPos endPos) - (Ast_helper.Exp.ident ~loc:arrayLoc arraySet) - [Nolabel, expr; Nolabel, accessExpr; Nolabel, rhsExpr] + let arraySet = + Ast_helper.Exp.apply ~loc:(mkLoc startPos endPos) + (Ast_helper.Exp.ident ~loc:arrayLoc arraySet) + [(Nolabel, expr); (Nolabel, accessExpr); (Nolabel, rhsExpr)] in Parser.eatBreadcrumb p; arraySet | _ -> let endPos = p.prevEndPos in let e = - Ast_helper.Exp.apply - ~loc:(mkLoc startPos endPos) - (Ast_helper.Exp.ident - ~loc:arrayLoc - (Location.mkloc (Longident.Ldot(Lident "Array", "get")) arrayLoc) - ) - [Nolabel, expr; Nolabel, accessExpr] + Ast_helper.Exp.apply ~loc:(mkLoc startPos endPos) + (Ast_helper.Exp.ident ~loc:arrayLoc + (Location.mkloc (Longident.Ldot (Lident "Array", "get")) arrayLoc)) + [(Nolabel, expr); (Nolabel, accessExpr)] in - parsePrimaryExpr ~operand:e p - end + parsePrimaryExpr ~operand:e p) (* * A primary expression represents * - atomic-expr @@ -2061,43 +2136,44 @@ and parseBracketAccess p expr startPos = * * The "operand" represents the expression that is operated on *) -and parsePrimaryExpr ~operand ?(noCall=false) p = +and parsePrimaryExpr ~operand ?(noCall = false) p = let startPos = operand.pexp_loc.loc_start in let rec loop p expr = match p.Parser.token with - | Dot -> + | Dot -> ( Parser.next p; let lident = parseValuePathAfterDot p in - begin match p.Parser.token with + match p.Parser.token with | Equal when noCall = false -> Parser.leaveBreadcrumb p Grammar.ExprSetField; Parser.next p; let targetExpr = parseExpr p in let loc = mkLoc startPos p.prevEndPos in - let setfield = Ast_helper.Exp.setfield ~loc expr lident targetExpr in + let setfield = Ast_helper.Exp.setfield ~loc expr lident targetExpr in Parser.eatBreadcrumb p; setfield | _ -> let endPos = p.prevEndPos in let loc = mkLoc startPos endPos in - loop p (Ast_helper.Exp.field ~loc expr lident) - end - | Lbracket when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + loop p (Ast_helper.Exp.field ~loc expr lident)) + | Lbracket + when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> parseBracketAccess p expr startPos - | Lparen when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + | Lparen when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum + -> loop p (parseCallExpr p expr) - | Backtick when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - begin match expr.pexp_desc with + | Backtick + when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> ( + match expr.pexp_desc with | Pexp_ident {txt = Longident.Lident ident} -> parseTemplateExpr ~prefix:ident p | _ -> - Parser.err - ~startPos:expr.pexp_loc.loc_start - ~endPos:expr.pexp_loc.loc_end - p - (Diagnostics.message "Tagged template literals are currently restricted to names like: json`null`."); - parseTemplateExpr p - end + Parser.err ~startPos:expr.pexp_loc.loc_start + ~endPos:expr.pexp_loc.loc_end p + (Diagnostics.message + "Tagged template literals are currently restricted to names like: \ + json`null`."); + parseTemplateExpr p) | _ -> expr in loop p operand @@ -2116,11 +2192,10 @@ and parseUnaryExpr p = let tokenEnd = p.endPos in Parser.next p; let operand = parseUnaryExpr p in - let unaryExpr = makeUnaryExpr startPos tokenEnd token operand in + let unaryExpr = makeUnaryExpr startPos tokenEnd token operand in Parser.eatBreadcrumb p; unaryExpr - | _ -> - parsePrimaryExpr ~operand:(parseAtomicExpr p) p + | _ -> parsePrimaryExpr ~operand:(parseAtomicExpr p) p (* Represents an "operand" in a binary expression. * If you have `a + b`, `a` and `b` both represent @@ -2128,38 +2203,34 @@ and parseUnaryExpr p = and parseOperandExpr ~context p = let startPos = p.Parser.startPos in let attrs = parseAttributes p in - let expr = match p.Parser.token with - | Assert -> - Parser.next p; - let expr = parseUnaryExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.assert_ ~loc expr - | Lazy -> - Parser.next p; - let expr = parseUnaryExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.lazy_ ~loc expr - | Try -> - parseTryExpression p - | If -> - parseIfOrIfLetExpression p - | For -> - parseForExpression p - | While -> - parseWhileExpression p - | Switch -> - parseSwitchExpression p - | _ -> - if (context != WhenExpr) && - isEs6ArrowExpression ~inTernary:(context=TernaryTrueBranchExpr) p - then - parseEs6ArrowExpression ~context p - else - parseUnaryExpr p + let expr = + match p.Parser.token with + | Assert -> + Parser.next p; + let expr = parseUnaryExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.assert_ ~loc expr + | Lazy -> + Parser.next p; + let expr = parseUnaryExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.lazy_ ~loc expr + | Try -> parseTryExpression p + | If -> parseIfOrIfLetExpression p + | For -> parseForExpression p + | While -> parseWhileExpression p + | Switch -> parseSwitchExpression p + | _ -> + if + context != WhenExpr + && isEs6ArrowExpression ~inTernary:(context = TernaryTrueBranchExpr) p + then parseEs6ArrowExpression ~context p + else parseUnaryExpr p in (* let endPos = p.Parser.prevEndPos in *) - {expr with - pexp_attributes = List.concat[expr.Parsetree.pexp_attributes; attrs]; + { + expr with + pexp_attributes = List.concat [expr.Parsetree.pexp_attributes; attrs]; (* pexp_loc = mkLoc startPos endPos *) } @@ -2168,10 +2239,11 @@ and parseOperandExpr ~context p = * a + b * f(x) |> g(y) *) -and parseBinaryExpr ?(context=OrdinaryExpr) ?a p prec = - let a = match a with - | Some e -> e - | None -> parseOperandExpr ~context p +and parseBinaryExpr ?(context = OrdinaryExpr) ?a p prec = + let a = + match a with + | Some e -> e + | None -> parseOperandExpr ~context p in let rec loop a = let token = p.Parser.token in @@ -2190,64 +2262,66 @@ and parseBinaryExpr ?(context=OrdinaryExpr) ?a p prec = * * First case is unary, second is a binary operator. * See Scanner.isBinaryOp *) - | Minus | MinusDot | LessThan when not ( - Scanner.isBinaryOp p.scanner.src p.startPos.pos_cnum p.endPos.pos_cnum - ) && p.startPos.pos_lnum > p.prevEndPos.pos_lnum -> -1 + | (Minus | MinusDot | LessThan) + when (not + (Scanner.isBinaryOp p.scanner.src p.startPos.pos_cnum + p.endPos.pos_cnum)) + && p.startPos.pos_lnum > p.prevEndPos.pos_lnum -> + -1 | token -> Token.precedence token in if tokenPrec < prec then a - else begin + else ( Parser.leaveBreadcrumb p (Grammar.ExprBinaryAfterOp token); let startPos = p.startPos in Parser.next p; let endPos = p.prevEndPos in let b = parseBinaryExpr ~context p (tokenPrec + 1) in let loc = mkLoc a.Parsetree.pexp_loc.loc_start b.pexp_loc.loc_end in - let expr = Ast_helper.Exp.apply - ~loc - (makeInfixOperator p token startPos endPos) - [Nolabel, a; Nolabel, b] + let expr = + Ast_helper.Exp.apply ~loc + (makeInfixOperator p token startPos endPos) + [(Nolabel, a); (Nolabel, b)] in Parser.eatBreadcrumb p; - loop expr - end + loop expr) in loop a (* If we even need this, determines if < might be the start of jsx. Not 100% complete *) (* and isStartOfJsx p = *) - (* Parser.lookahead p (fun p -> *) - (* match p.Parser.token with *) - (* | LessThan -> *) - (* Parser.next p; *) - (* begin match p.token with *) - (* | GreaterThan (* <> *) -> true *) - (* | Lident _ | Uident _ | List -> *) - (* ignore (parseJsxName p); *) - (* begin match p.token with *) - (* | GreaterThan (*
*) -> true *) - (* | Question (* true *) - (* | Lident _ | List -> *) - (* Parser.next p; *) - (* begin match p.token with *) - (* | Equal (* true *) - (* | _ -> false (* TODO *) *) - (* end *) - (* | Forwardslash (* *) - (* Parser.next p; *) - (* begin match p.token with *) - (* | GreaterThan (* *) -> true *) - (* | _ -> false *) - (* end *) - (* | _ -> *) - (* false *) - (* end *) - (* | _ -> false *) - (* end *) - (* | _ -> false *) - (* ) *) - -and parseTemplateExpr ?(prefix="js") p = +(* Parser.lookahead p (fun p -> *) +(* match p.Parser.token with *) +(* | LessThan -> *) +(* Parser.next p; *) +(* begin match p.token with *) +(* | GreaterThan (* <> *) -> true *) +(* | Lident _ | Uident _ | List -> *) +(* ignore (parseJsxName p); *) +(* begin match p.token with *) +(* | GreaterThan (*
*) -> true *) +(* | Question (* true *) +(* | Lident _ | List -> *) +(* Parser.next p; *) +(* begin match p.token with *) +(* | Equal (* true *) +(* | _ -> false (* TODO *) *) +(* end *) +(* | Forwardslash (* *) +(* Parser.next p; *) +(* begin match p.token with *) +(* | GreaterThan (* *) -> true *) +(* | _ -> false *) +(* end *) +(* | _ -> *) +(* false *) +(* end *) +(* | _ -> false *) +(* end *) +(* | _ -> false *) +(* ) *) + +and parseTemplateExpr ?(prefix = "js") p = let hiddenOperator = let op = Location.mknoloc (Longident.Lident "^") in Ast_helper.Exp.ident op @@ -2259,48 +2333,77 @@ and parseTemplateExpr ?(prefix="js") p = | TemplateTail txt -> Parser.next p; let loc = mkLoc startPos p.prevEndPos in - let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in - let str = Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc (Pconst_string(txt, Some prefix)) in + let txt = + if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt + else txt + in + let str = + Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc + (Pconst_string (txt, Some prefix)) + in Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc hiddenOperator - [Nolabel, acc; Nolabel, str] + [(Nolabel, acc); (Nolabel, str)] | TemplatePart txt -> Parser.next p; let loc = mkLoc startPos p.prevEndPos in let expr = parseExprBlock p in let fullLoc = mkLoc startPos p.prevEndPos in - let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in - let str = Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc (Pconst_string(txt, Some prefix)) in + let txt = + if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt + else txt + in + let str = + Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc + (Pconst_string (txt, Some prefix)) + in let next = - let a = Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc:fullLoc hiddenOperator [Nolabel, acc; Nolabel, str] in + let a = + Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc:fullLoc + hiddenOperator + [(Nolabel, acc); (Nolabel, str)] + in Ast_helper.Exp.apply ~loc:fullLoc hiddenOperator - [Nolabel, a; Nolabel, expr] + [(Nolabel, a); (Nolabel, expr)] in parseParts next - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Ast_helper.Exp.constant (Pconst_string("", None)) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Ast_helper.Exp.constant (Pconst_string ("", None)) in let startPos = p.startPos in Parser.nextTemplateLiteralToken p; match p.token with | TemplateTail txt -> Parser.next p; - let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc:(mkLoc startPos p.prevEndPos) (Pconst_string(txt, Some prefix)) + let txt = + if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt + else txt + in + Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] + ~loc:(mkLoc startPos p.prevEndPos) + (Pconst_string (txt, Some prefix)) | TemplatePart txt -> Parser.next p; let constantLoc = mkLoc startPos p.prevEndPos in let expr = parseExprBlock p in let fullLoc = mkLoc startPos p.prevEndPos in - let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in - let str = Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc:constantLoc (Pconst_string(txt, Some prefix)) in + let txt = + if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt + else txt + in + let str = + Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc:constantLoc + (Pconst_string (txt, Some prefix)) + in let next = - Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc:fullLoc hiddenOperator [Nolabel, str; Nolabel, expr] + Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc:fullLoc + hiddenOperator + [(Nolabel, str); (Nolabel, expr)] in parseParts next - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Ast_helper.Exp.constant (Pconst_string("", None)) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Ast_helper.Exp.constant (Pconst_string ("", None)) (* Overparse: let f = a : int => a + 1, is it (a : int) => or (a): int => * Also overparse constraints: @@ -2310,86 +2413,90 @@ and parseTemplateExpr ?(prefix="js") p = * } * * We want to give a nice error message in these cases - * *) + * *) and overParseConstrainedOrCoercedOrArrowExpression p expr = match p.Parser.token with - | ColonGreaterThan -> - parseCoercedExpr ~expr p - | Colon -> + | ColonGreaterThan -> parseCoercedExpr ~expr p + | Colon -> ( Parser.next p; let typ = parseTypExpr ~es6Arrow:false p in - begin match p.Parser.token with + match p.Parser.token with | EqualGreater -> Parser.next p; let body = parseExpr p in - let pat = match expr.pexp_desc with - | Pexp_ident longident -> - Ast_helper.Pat.var ~loc:expr.pexp_loc - (Location.mkloc - (Longident.flatten longident.txt |> String.concat ".") - longident.loc) - (* TODO: can we convert more expressions to patterns?*) - | _ -> - Ast_helper.Pat.var ~loc:expr.pexp_loc (Location.mkloc "pattern" expr.pexp_loc) + let pat = + match expr.pexp_desc with + | Pexp_ident longident -> + Ast_helper.Pat.var ~loc:expr.pexp_loc + (Location.mkloc + (Longident.flatten longident.txt |> String.concat ".") + longident.loc) + (* TODO: can we convert more expressions to patterns?*) + | _ -> + Ast_helper.Pat.var ~loc:expr.pexp_loc + (Location.mkloc "pattern" expr.pexp_loc) in - let arrow1 = Ast_helper.Exp.fun_ - ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) - Asttypes.Nolabel - None - pat - (Ast_helper.Exp.constraint_ body typ) + let arrow1 = + Ast_helper.Exp.fun_ + ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) + Asttypes.Nolabel None pat + (Ast_helper.Exp.constraint_ body typ) in - let arrow2 = Ast_helper.Exp.fun_ - ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) - Asttypes.Nolabel - None - (Ast_helper.Pat.constraint_ pat typ) - body + let arrow2 = + Ast_helper.Exp.fun_ + ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) + Asttypes.Nolabel None + (Ast_helper.Pat.constraint_ pat typ) + body in let msg = - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.text "Did you mean to annotate the parameter type or the return type?"; - Doc.indent ( - Doc.concat [ - Doc.line; - Doc.text "1) "; - ResPrinter.printExpression arrow1 CommentTable.empty; - Doc.line; - Doc.text "2) "; - ResPrinter.printExpression arrow2 CommentTable.empty; - ] - ) - ] - ) |> Doc.toString ~width:80 + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text + "Did you mean to annotate the parameter type or the return \ + type?"; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.text "1) "; + ResPrinter.printExpression arrow1 CommentTable.empty; + Doc.line; + Doc.text "2) "; + ResPrinter.printExpression arrow2 CommentTable.empty; + ]); + ]) + |> Doc.toString ~width:80 in - Parser.err - ~startPos:expr.pexp_loc.loc_start - ~endPos:body.pexp_loc.loc_end - p - (Diagnostics.message msg); + Parser.err ~startPos:expr.pexp_loc.loc_start ~endPos:body.pexp_loc.loc_end + p (Diagnostics.message msg); arrow1 | _ -> let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in let expr = Ast_helper.Exp.constraint_ ~loc expr typ in - let () = Parser.err - ~startPos:expr.pexp_loc.loc_start - ~endPos:typ.ptyp_loc.loc_end - p - (Diagnostics.message - (Doc.breakableGroup ~forceBreak:true (Doc.concat [ - Doc.text "Expressions with type constraints need to be wrapped in parens:"; - Doc.indent ( - Doc.concat [ - Doc.line; - ResPrinter.addParens (ResPrinter.printExpression expr CommentTable.empty); - ] - ) - ]) |> Doc.toString ~width:80 - )) + let () = + Parser.err ~startPos:expr.pexp_loc.loc_start + ~endPos:typ.ptyp_loc.loc_end p + (Diagnostics.message + (Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text + "Expressions with type constraints need to be wrapped \ + in parens:"; + Doc.indent + (Doc.concat + [ + Doc.line; + ResPrinter.addParens + (ResPrinter.printExpression expr + CommentTable.empty); + ]); + ]) + |> Doc.toString ~width:80)) in - expr - end + expr) | _ -> expr and parseLetBindingBody ~startPos ~attrs p = @@ -2400,10 +2507,11 @@ and parseLetBindingBody ~startPos ~attrs p = let pat = parsePattern p in Parser.eatBreadcrumb p; match p.Parser.token with - | Colon -> + | Colon -> ( Parser.next p; - begin match p.token with - | Typ -> (* locally abstract types *) + match p.token with + | Typ -> + (* locally abstract types *) Parser.next p; let newtypes = parseLidentList p in Parser.expect Dot p; @@ -2416,16 +2524,19 @@ and parseLetBindingBody ~startPos ~attrs p = (pat, exp) | _ -> let polyType = parsePolyTypeExpr p in - let loc = {pat.ppat_loc with loc_end = polyType.Parsetree.ptyp_loc.loc_end} in + let loc = + {pat.ppat_loc with loc_end = polyType.Parsetree.ptyp_loc.loc_end} + in let pat = Ast_helper.Pat.constraint_ ~loc pat polyType in Parser.expect Token.Equal p; let exp = parseExpr p in let exp = overParseConstrainedOrCoercedOrArrowExpression p exp in - (pat, exp) - end + (pat, exp)) | _ -> Parser.expect Token.Equal p; - let exp = overParseConstrainedOrCoercedOrArrowExpression p (parseExpr p) in + let exp = + overParseConstrainedOrCoercedOrArrowExpression p (parseExpr p) + in (pat, exp) in let loc = mkLoc startPos p.prevEndPos in @@ -2466,11 +2577,10 @@ and parseAttributesAndBinding (p : Parser.t) = let comments = p.comments in match p.Parser.token with - | At -> + | At -> ( let attrs = parseAttributes p in - begin match p.Parser.token with - | And -> - attrs + match p.Parser.token with + | And -> attrs | _ -> p.scanner.err <- err; p.scanner.ch <- ch; @@ -2486,18 +2596,16 @@ and parseAttributesAndBinding (p : Parser.t) = p.errors <- errors; p.diagnostics <- diagnostics; p.comments <- comments; - [] - end + []) | _ -> [] (* definition ::= let [rec] let-binding { and let-binding } *) and parseLetBindings ~attrs p = let startPos = p.Parser.startPos in Parser.optional p Let |> ignore; - let recFlag = if Parser.optional p Token.Rec then - Asttypes.Recursive - else - Asttypes.Nonrecursive + let recFlag = + if Parser.optional p Token.Rec then Asttypes.Recursive + else Asttypes.Nonrecursive in let first = parseLetBindingBody ~startPos ~attrs p in @@ -2507,19 +2615,22 @@ and parseLetBindings ~attrs p = match p.Parser.token with | And -> Parser.next p; - let attrs = match p.token with - | Export -> - let exportLoc = mkLoc p.startPos p.endPos in - Parser.next p; - let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in - genTypeAttr::attrs - | _ -> attrs + let attrs = + match p.token with + | Export -> + let exportLoc = mkLoc p.startPos p.endPos in + Parser.next p; + let genTypeAttr = + (Location.mkloc "genType" exportLoc, Parsetree.PStr []) + in + genTypeAttr :: attrs + | _ -> attrs in - ignore(Parser.optional p Let); (* overparse for fault tolerance *) + ignore (Parser.optional p Let); + (* overparse for fault tolerance *) let letBinding = parseLetBindingBody ~startPos ~attrs p in - loop p (letBinding::bindings) - | _ -> - List.rev bindings + loop p (letBinding :: bindings) + | _ -> List.rev bindings in (recFlag, loop p [first]) @@ -2529,21 +2640,26 @@ and parseLetBindings ~attrs p = * Foo.Bar -> Foo.Bar.createElement *) and parseJsxName p = - let longident = match p.Parser.token with - | Lident ident -> - let identStart = p.startPos in - let identEnd = p.endPos in - Parser.next p; - let loc = mkLoc identStart identEnd in - Location.mkloc (Longident.Lident ident) loc - | Uident _ -> - let longident = parseModuleLongIdent ~lowercase:true p in - Location.mkloc (Longident.Ldot (longident.txt, "createElement")) longident.loc - | _ -> - let msg = "A jsx name must be a lowercase or uppercase name, like: div in
or Navbar in " - in - Parser.err p (Diagnostics.message msg); - Location.mknoloc (Longident.Lident "_") + let longident = + match p.Parser.token with + | Lident ident -> + let identStart = p.startPos in + let identEnd = p.endPos in + Parser.next p; + let loc = mkLoc identStart identEnd in + Location.mkloc (Longident.Lident ident) loc + | Uident _ -> + let longident = parseModuleLongIdent ~lowercase:true p in + Location.mkloc + (Longident.Ldot (longident.txt, "createElement")) + longident.loc + | _ -> + let msg = + "A jsx name must be a lowercase or uppercase name, like: div in
or Navbar in " + in + Parser.err p (Diagnostics.message msg); + Location.mknoloc (Longident.Lident "_") in Ast_helper.Exp.ident ~loc:longident.loc longident @@ -2551,69 +2667,77 @@ and parseJsxOpeningOrSelfClosingElement ~startPos p = let jsxStartPos = p.Parser.startPos in let name = parseJsxName p in let jsxProps = parseJsxProps p in - let children = match p.Parser.token with - | Forwardslash -> (* *) - let childrenStartPos = p.Parser.startPos in - Parser.next p; - let childrenEndPos = p.Parser.startPos in - Parser.expect GreaterThan p; - let loc = mkLoc childrenStartPos childrenEndPos in - makeListExpression loc [] None (* no children *) - | GreaterThan -> (* bar *) - let childrenStartPos = p.Parser.startPos in - Scanner.setJsxMode p.scanner; - Parser.next p; - let (spread, children) = parseJsxChildren p in - let childrenEndPos = p.Parser.startPos in - let () = match p.token with - | LessThanSlash -> Parser.next p - | LessThan -> Parser.next p; Parser.expect Forwardslash p - | token when Grammar.isStructureItemStart token -> () - | _ -> Parser.expect LessThanSlash p - in - begin match p.Parser.token with - | Lident _ | Uident _ when verifyJsxOpeningClosingName p name -> + let children = + match p.Parser.token with + | Forwardslash -> + (* *) + let childrenStartPos = p.Parser.startPos in + Parser.next p; + let childrenEndPos = p.Parser.startPos in Parser.expect GreaterThan p; let loc = mkLoc childrenStartPos childrenEndPos in - ( match spread, children with - | true, child :: _ -> - child - | _ -> - makeListExpression loc children None - ) - | token -> - let () = if Grammar.isStructureItemStart token then ( - let closing = "" in - let msg = Diagnostics.message ("Missing " ^ closing) in - Parser.err ~startPos ~endPos:p.prevEndPos p msg; - ) else ( - let opening = "" in - let msg = "Closing jsx name should be the same as the opening name. Did you mean " ^ opening ^ " ?" in - Parser.err ~startPos ~endPos:p.prevEndPos p (Diagnostics.message msg); - Parser.expect GreaterThan p - ) + makeListExpression loc [] None (* no children *) + | GreaterThan -> ( + (* bar *) + let childrenStartPos = p.Parser.startPos in + Scanner.setJsxMode p.scanner; + Parser.next p; + let spread, children = parseJsxChildren p in + let childrenEndPos = p.Parser.startPos in + let () = + match p.token with + | LessThanSlash -> Parser.next p + | LessThan -> + Parser.next p; + Parser.expect Forwardslash p + | token when Grammar.isStructureItemStart token -> () + | _ -> Parser.expect LessThanSlash p in - let loc = mkLoc childrenStartPos childrenEndPos in - ( match spread, children with - | true, child :: _ -> - child - | _ -> - makeListExpression loc children None - ) - end - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - makeListExpression Location.none [] None + match p.Parser.token with + | (Lident _ | Uident _) when verifyJsxOpeningClosingName p name -> ( + Parser.expect GreaterThan p; + let loc = mkLoc childrenStartPos childrenEndPos in + match (spread, children) with + | true, child :: _ -> child + | _ -> makeListExpression loc children None) + | token -> ( + let () = + if Grammar.isStructureItemStart token then + let closing = "" in + let msg = Diagnostics.message ("Missing " ^ closing) in + Parser.err ~startPos ~endPos:p.prevEndPos p msg + else + let opening = "" in + let msg = + "Closing jsx name should be the same as the opening name. Did \ + you mean " ^ opening ^ " ?" + in + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message msg); + Parser.expect GreaterThan p + in + let loc = mkLoc childrenStartPos childrenEndPos in + match (spread, children) with + | true, child :: _ -> child + | _ -> makeListExpression loc children None)) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + makeListExpression Location.none [] None in let jsxEndPos = p.prevEndPos in let loc = mkLoc jsxStartPos jsxEndPos in - Ast_helper.Exp.apply - ~loc - name - (List.concat [jsxProps; [ - (Asttypes.Labelled "children", children); - (Asttypes.Nolabel, Ast_helper.Exp.construct (Location.mknoloc (Longident.Lident "()")) None) - ]]) + Ast_helper.Exp.apply ~loc name + (List.concat + [ + jsxProps; + [ + (Asttypes.Labelled "children", children); + ( Asttypes.Nolabel, + Ast_helper.Exp.construct + (Location.mknoloc (Longident.Lident "()")) + None ); + ]; + ]) (* * jsx ::= @@ -2627,13 +2751,13 @@ and parseJsx p = Parser.leaveBreadcrumb p Grammar.Jsx; let startPos = p.Parser.startPos in Parser.expect LessThan p; - let jsxExpr = match p.Parser.token with - | Lident _ | Uident _ -> - parseJsxOpeningOrSelfClosingElement ~startPos p - | GreaterThan -> (* fragment: <> foo *) - parseJsxFragment p - | _ -> - parseJsxName p + let jsxExpr = + match p.Parser.token with + | Lident _ | Uident _ -> parseJsxOpeningOrSelfClosingElement ~startPos p + | GreaterThan -> + (* fragment: <> foo *) + parseJsxFragment p + | _ -> parseJsxName p in Parser.eatBreadcrumb p; {jsxExpr with pexp_attributes = [jsxAttr]} @@ -2647,14 +2771,13 @@ and parseJsxFragment p = let childrenStartPos = p.Parser.startPos in Scanner.setJsxMode p.scanner; Parser.expect GreaterThan p; - let (_spread, children) = parseJsxChildren p in + let _spread, children = parseJsxChildren p in let childrenEndPos = p.Parser.startPos in Parser.expect LessThanSlash p; Parser.expect GreaterThan p; let loc = mkLoc childrenStartPos childrenEndPos in makeListExpression loc children None - (* * jsx-prop ::= * | lident @@ -2664,18 +2787,19 @@ and parseJsxFragment p = *) and parseJsxProp p = match p.Parser.token with - | Question | Lident _ -> + | Question | Lident _ -> ( let optional = Parser.optional p Question in - let (name, loc) = parseLident p in - let propLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in + let name, loc = parseLident p in + let propLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + in (* optional punning: *) if optional then - Some ( - Asttypes.Optional name, - Ast_helper.Exp.ident ~attrs:[propLocAttr] - ~loc (Location.mkloc (Longident.Lident name) loc) - ) - else begin + Some + ( Asttypes.Optional name, + Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc + (Location.mkloc (Longident.Lident name) loc) ) + else match p.Parser.token with | Equal -> Parser.next p; @@ -2683,7 +2807,7 @@ and parseJsxProp p = let optional = Parser.optional p Question in let attrExpr = let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in - {e with pexp_attributes = propLocAttr::e.pexp_attributes} + {e with pexp_attributes = propLocAttr :: e.pexp_attributes} in let label = if optional then Asttypes.Optional name else Asttypes.Labelled name @@ -2692,24 +2816,20 @@ and parseJsxProp p = | _ -> let attrExpr = Ast_helper.Exp.ident ~loc ~attrs:[propLocAttr] - (Location.mkloc (Longident.Lident name) loc) in + (Location.mkloc (Longident.Lident name) loc) + in let label = if optional then Asttypes.Optional name else Asttypes.Labelled name in - Some (label, attrExpr) - end - | _ -> - None + Some (label, attrExpr)) + | _ -> None and parseJsxProps p = - parseRegion - ~grammar:Grammar.JsxAttribute - ~f:parseJsxProp - p + parseRegion ~grammar:Grammar.JsxAttribute ~f:parseJsxProp p and parseJsxChildren p = let rec loop p children = - match p.Parser.token with + match p.Parser.token with | Token.Eof | LessThanSlash -> Scanner.popMode p.scanner Jsx; List.rev children @@ -2721,16 +2841,21 @@ and parseJsxChildren p = * determines the correct token to disambiguate *) let token = Scanner.reconsiderLessThan p.scanner in if token = LessThan then - let child = parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p in - loop p (child::children) - else (* LessThanSlash *) + let child = + parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p + in + loop p (child :: children) + else + (* LessThanSlash *) let () = p.token <- token in let () = Scanner.popMode p.scanner Jsx in List.rev children | token when Grammar.isJsxChildStart token -> let () = Scanner.popMode p.scanner Jsx in - let child = parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p in - loop p (child::children) + let child = + parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p + in + loop p (child :: children) | _ -> Scanner.popMode p.scanner Jsx; List.rev children @@ -2741,7 +2866,7 @@ and parseJsxChildren p = (true, [parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p]) | _ -> (false, loop p []) -and parseBracedOrRecordExpr p = +and parseBracedOrRecordExpr p = let startPos = p.Parser.startPos in Parser.expect Lbrace p; match p.Parser.token with @@ -2751,7 +2876,8 @@ and parseBracedOrRecordExpr p = let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in Ast_helper.Exp.construct ~attrs:[braces] ~loc - (Location.mkloc (Longident.Lident "()") loc) None + (Location.mkloc (Longident.Lident "()") loc) + None | DotDotDot -> (* beginning of record spread, parse record *) Parser.next p; @@ -2760,14 +2886,14 @@ and parseBracedOrRecordExpr p = let expr = parseRecordExpr ~startPos ~spread:(Some spreadExpr) [] p in Parser.expect Rbrace p; expr - | String s -> + | String s -> ( let s = if p.mode = ParseForTypeChecker then parseStringLiteral s else s in let field = let loc = mkLoc p.startPos p.endPos in Parser.next p; Location.mkloc (Longident.Lident s) loc in - begin match p.Parser.token with + match p.Parser.token with | Colon -> Parser.next p; let fieldExpr = parseExpr p in @@ -2775,52 +2901,59 @@ and parseBracedOrRecordExpr p = let expr = parseRecordExprWithStringKeys ~startPos (field, fieldExpr) p in Parser.expect Rbrace p; expr - | _ -> + | _ -> ( let tag = if p.mode = ParseForTypeChecker then Some "js" else None in - let constant = Ast_helper.Exp.constant ~loc:field.loc (Parsetree.Pconst_string(s, tag)) in + let constant = + Ast_helper.Exp.constant ~loc:field.loc + (Parsetree.Pconst_string (s, tag)) + in let a = parsePrimaryExpr ~operand:constant p in let e = parseBinaryExpr ~a p 1 in let e = parseTernaryExpr e p in - begin match p.Parser.token with + match p.Parser.token with | Semicolon -> let expr = parseExprBlock ~first:e p in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in - {expr with Parsetree.pexp_attributes = braces::expr.Parsetree.pexp_attributes} + { + expr with + Parsetree.pexp_attributes = braces :: expr.Parsetree.pexp_attributes; + } | Rbrace -> Parser.next p; let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in - {e with pexp_attributes = braces::e.pexp_attributes} + {e with pexp_attributes = braces :: e.pexp_attributes} | _ -> let expr = parseExprBlock ~first:e p in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - end - end - | Uident _ | Lident _ -> + {expr with pexp_attributes = braces :: expr.pexp_attributes})) + | Uident _ | Lident _ -> ( let startToken = p.token in let valueOrConstructor = parseValueOrConstructor p in - begin match valueOrConstructor.pexp_desc with - | Pexp_ident pathIdent -> + match valueOrConstructor.pexp_desc with + | Pexp_ident pathIdent -> ( let identEndPos = p.prevEndPos in - begin match p.Parser.token with + match p.Parser.token with | Comma -> Parser.next p; - let valueOrConstructor = match startToken with - | Uident _ -> removeModuleNameFromPunnedFieldValue(valueOrConstructor) - | _ -> valueOrConstructor + let valueOrConstructor = + match startToken with + | Uident _ -> removeModuleNameFromPunnedFieldValue valueOrConstructor + | _ -> valueOrConstructor + in + let expr = + parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in - let expr = parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in Parser.expect Rbrace p; expr - | Colon -> + | Colon -> ( Parser.next p; let fieldExpr = parseExpr p in - begin match p.token with + match p.token with | Rbrace -> Parser.next p; let loc = mkLoc startPos p.prevEndPos in @@ -2829,244 +2962,247 @@ and parseBracedOrRecordExpr p = Parser.expect Comma p; let expr = parseRecordExpr ~startPos [(pathIdent, fieldExpr)] p in Parser.expect Rbrace p; - expr - end + expr) (* error case *) | Lident _ -> if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then ( Parser.expect Comma p; - let expr = parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in + let expr = + parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p + in Parser.expect Rbrace p; - expr - ) else ( + expr) + else ( Parser.expect Colon p; - let expr = parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in + let expr = + parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p + in Parser.expect Rbrace p; - expr - ) + expr) | Semicolon -> let expr = parseExprBlock ~first:(Ast_helper.Exp.ident pathIdent) p in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} + {expr with pexp_attributes = braces :: expr.pexp_attributes} | Rbrace -> Parser.next p; let expr = Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent in let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - | EqualGreater -> + {expr with pexp_attributes = braces :: expr.pexp_attributes} + | EqualGreater -> ( let loc = mkLoc startPos identEndPos in let ident = Location.mkloc (Longident.last pathIdent.txt) loc in - let a = parseEs6ArrowExpression - ~parameters:[TermParameter { - uncurried = false; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = Ast_helper.Pat.var ident; - pos = startPos; - }] - p + let a = + parseEs6ArrowExpression + ~parameters: + [ + TermParameter + { + uncurried = false; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = Ast_helper.Pat.var ident; + pos = startPos; + }; + ] + p in let e = parseBinaryExpr ~a p 1 in let e = parseTernaryExpr e p in - begin match p.Parser.token with + match p.Parser.token with | Semicolon -> let expr = parseExprBlock ~first:e p in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} + {expr with pexp_attributes = braces :: expr.pexp_attributes} | Rbrace -> Parser.next p; let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in - {e with pexp_attributes = braces::e.pexp_attributes} + {e with pexp_attributes = braces :: e.pexp_attributes} | _ -> let expr = parseExprBlock ~first:e p in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - end - | _ -> + {expr with pexp_attributes = braces :: expr.pexp_attributes}) + | _ -> ( Parser.leaveBreadcrumb p Grammar.ExprBlock; - let a = parsePrimaryExpr ~operand:(Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent) p in + let a = + parsePrimaryExpr + ~operand:(Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent) + p + in let e = parseBinaryExpr ~a p 1 in let e = parseTernaryExpr e p in Parser.eatBreadcrumb p; - begin match p.Parser.token with + match p.Parser.token with | Semicolon -> let expr = parseExprBlock ~first:e p in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} + {expr with pexp_attributes = braces :: expr.pexp_attributes} | Rbrace -> Parser.next p; let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in - {e with pexp_attributes = braces::e.pexp_attributes} + {e with pexp_attributes = braces :: e.pexp_attributes} | _ -> let expr = parseExprBlock ~first:e p in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - end - end - | _ -> + {expr with pexp_attributes = braces :: expr.pexp_attributes})) + | _ -> ( Parser.leaveBreadcrumb p Grammar.ExprBlock; let a = parsePrimaryExpr ~operand:valueOrConstructor p in let e = parseBinaryExpr ~a p 1 in let e = parseTernaryExpr e p in Parser.eatBreadcrumb p; - begin match p.Parser.token with + match p.Parser.token with | Semicolon -> let expr = parseExprBlock ~first:e p in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} + {expr with pexp_attributes = braces :: expr.pexp_attributes} | Rbrace -> Parser.next p; let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in - {e with pexp_attributes = braces::e.pexp_attributes} + {e with pexp_attributes = braces :: e.pexp_attributes} | _ -> let expr = parseExprBlock ~first:e p in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - end - end + {expr with pexp_attributes = braces :: expr.pexp_attributes})) | _ -> let expr = parseExprBlock p in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} + {expr with pexp_attributes = braces :: expr.pexp_attributes} and parseRecordRowWithStringKey p = match p.Parser.token with - | String s -> + | String s -> ( let loc = mkLoc p.startPos p.endPos in Parser.next p; let field = Location.mkloc (Longident.Lident s) loc in - begin match p.Parser.token with + match p.Parser.token with | Colon -> Parser.next p; let fieldExpr = parseExpr p in Some (field, fieldExpr) - | _ -> - Some (field, Ast_helper.Exp.ident ~loc:field.loc field) - end + | _ -> Some (field, Ast_helper.Exp.ident ~loc:field.loc field)) | _ -> None and parseRecordRow p = - let () = match p.Parser.token with - | Token.DotDotDot -> - Parser.err p (Diagnostics.message ErrorMessages.recordExprSpread); - Parser.next p; - | _ -> () + let () = + match p.Parser.token with + | Token.DotDotDot -> + Parser.err p (Diagnostics.message ErrorMessages.recordExprSpread); + Parser.next p + | _ -> () in match p.Parser.token with - | Lident _ | Uident _ -> + | Lident _ | Uident _ -> ( let startToken = p.token in let field = parseValuePath p in - begin match p.Parser.token with + match p.Parser.token with | Colon -> Parser.next p; let fieldExpr = parseExpr p in Some (field, fieldExpr) | _ -> let value = Ast_helper.Exp.ident ~loc:field.loc field in - let value = match startToken with - | Uident _ -> removeModuleNameFromPunnedFieldValue(value) - | _ -> value + let value = + match startToken with + | Uident _ -> removeModuleNameFromPunnedFieldValue value + | _ -> value in - Some (field, value) - end + Some (field, value)) | _ -> None and parseRecordExprWithStringKeys ~startPos firstRow p = - let rows = firstRow::( - parseCommaDelimitedRegion ~grammar:Grammar.RecordRowsStringKey ~closing:Rbrace ~f:parseRecordRowWithStringKey p - ) in - let loc = mkLoc startPos p.endPos in - let recordStrExpr = Ast_helper.Str.eval ~loc ( - Ast_helper.Exp.record ~loc rows None - ) in + let rows = + firstRow + :: parseCommaDelimitedRegion ~grammar:Grammar.RecordRowsStringKey + ~closing:Rbrace ~f:parseRecordRowWithStringKey p + in + let loc = mkLoc startPos p.endPos in + let recordStrExpr = + Ast_helper.Str.eval ~loc (Ast_helper.Exp.record ~loc rows None) + in Ast_helper.Exp.extension ~loc (Location.mkloc "obj" loc, Parsetree.PStr [recordStrExpr]) -and parseRecordExpr ~startPos ?(spread=None) rows p = +and parseRecordExpr ~startPos ?(spread = None) rows p = let exprs = - parseCommaDelimitedRegion - ~grammar:Grammar.RecordRows - ~closing:Rbrace + parseCommaDelimitedRegion ~grammar:Grammar.RecordRows ~closing:Rbrace ~f:parseRecordRow p in let rows = List.concat [rows; exprs] in - let () = match rows with - | [] -> - let msg = "Record spread needs at least one field that's updated" in - Parser.err p (Diagnostics.message msg); - | _rows -> () + let () = + match rows with + | [] -> + let msg = "Record spread needs at least one field that's updated" in + Parser.err p (Diagnostics.message msg) + | _rows -> () in let loc = mkLoc startPos p.endPos in Ast_helper.Exp.record ~loc rows spread - and parseNewlineOrSemicolonExprBlock p = match p.Parser.token with - | Semicolon -> - Parser.next p + | Semicolon -> Parser.next p | token when Grammar.isBlockExprStart token -> if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () else - Parser.err - ~startPos:p.prevEndPos - ~endPos: p.endPos - p - (Diagnostics.message "consecutive expressions on a line must be separated by ';' or a newline") + Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p + (Diagnostics.message + "consecutive expressions on a line must be separated by ';' or a \ + newline") | _ -> () and parseExprBlockItem p = let startPos = p.Parser.startPos in let attrs = parseAttributes p in match p.Parser.token with - | Module -> + | Module -> ( Parser.next p; - begin match p.token with + match p.token with | Lparen -> let expr = parseFirstClassModuleExpr ~startPos p in let a = parsePrimaryExpr ~operand:expr p in let expr = parseBinaryExpr ~a p 1 in parseTernaryExpr expr p | _ -> - let name = match p.Parser.token with - | Uident ident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + let name = + match p.Parser.token with + | Uident ident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in let body = parseModuleBindingBody p in parseNewlineOrSemicolonExprBlock p; let expr = parseExprBlock p in let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.letmodule ~loc name body expr - end + Ast_helper.Exp.letmodule ~loc name body expr) | Exception -> let extensionConstructor = parseExceptionDef ~attrs p in parseNewlineOrSemicolonExprBlock p; - let blockExpr = parseExprBlock p in + let blockExpr = parseExprBlock p in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.letexception ~loc extensionConstructor blockExpr | Open -> @@ -3076,14 +3212,15 @@ and parseExprBlockItem p = let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.open_ ~loc od.popen_override od.popen_lid blockExpr | Let -> - let (recFlag, letBindings) = parseLetBindings ~attrs p in + let recFlag, letBindings = parseLetBindings ~attrs p in parseNewlineOrSemicolonExprBlock p; - let next = if Grammar.isBlockExprStart p.Parser.token then - parseExprBlock p - else - let loc = mkLoc p.startPos p.endPos in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) None + let next = + if Grammar.isBlockExprStart p.Parser.token then parseExprBlock p + else + let loc = mkLoc p.startPos p.endPos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.let_ ~loc recFlag letBindings next @@ -3114,17 +3251,18 @@ and parseExprBlockItem p = *) and parseExprBlock ?first p = Parser.leaveBreadcrumb p Grammar.ExprBlock; - let item = match first with - | Some e -> e - | None -> parseExprBlockItem p + let item = + match first with + | Some e -> e + | None -> parseExprBlockItem p in parseNewlineOrSemicolonExprBlock p; - let blockExpr = if Grammar.isBlockExprStart p.Parser.token then - let next = parseExprBlockItem p in - let loc = {item.pexp_loc with loc_end = next.pexp_loc.loc_end} in - Ast_helper.Exp.sequence ~loc item next - else - item + let blockExpr = + if Grammar.isBlockExprStart p.Parser.token then + let next = parseExprBlockItem p in + let loc = {item.pexp_loc with loc_end = next.pexp_loc.loc_end} in + Ast_helper.Exp.sequence ~loc item next + else item in Parser.eatBreadcrumb p; overParseConstrainedOrCoercedOrArrowExpression p blockExpr @@ -3159,29 +3297,29 @@ and parseElseBranch p = Parser.expect Lbrace p; let blockExpr = parseExprBlock p in Parser.expect Rbrace p; - blockExpr; + blockExpr and parseIfExpr startPos p = let conditionExpr = parseIfCondition p in let thenExpr = parseThenBranch p in - let elseExpr = match p.Parser.token with - | Else -> - Parser.endRegion p; - Parser.leaveBreadcrumb p Grammar.ElseBranch; - Parser.next p; - Parser.beginRegion p; - let elseExpr = match p.token with - | If -> - parseIfOrIfLetExpression p + let elseExpr = + match p.Parser.token with + | Else -> + Parser.endRegion p; + Parser.leaveBreadcrumb p Grammar.ElseBranch; + Parser.next p; + Parser.beginRegion p; + let elseExpr = + match p.token with + | If -> parseIfOrIfLetExpression p + | _ -> parseElseBranch p + in + Parser.eatBreadcrumb p; + Parser.endRegion p; + Some elseExpr | _ -> - parseElseBranch p - in - Parser.eatBreadcrumb p; - Parser.endRegion p; - Some elseExpr - | _ -> - Parser.endRegion p; - None + Parser.endRegion p; + None in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.ifthenelse ~loc conditionExpr thenExpr elseExpr @@ -3191,63 +3329,67 @@ and parseIfLetExpr startPos p = Parser.expect Equal p; let conditionExpr = parseIfCondition p in let thenExpr = parseThenBranch p in - let elseExpr = match p.Parser.token with - | Else -> - Parser.endRegion p; - Parser.leaveBreadcrumb p Grammar.ElseBranch; - Parser.next p; - Parser.beginRegion p; - let elseExpr = match p.token with - | If -> - parseIfOrIfLetExpression p + let elseExpr = + match p.Parser.token with + | Else -> + Parser.endRegion p; + Parser.leaveBreadcrumb p Grammar.ElseBranch; + Parser.next p; + Parser.beginRegion p; + let elseExpr = + match p.token with + | If -> parseIfOrIfLetExpression p + | _ -> parseElseBranch p + in + Parser.eatBreadcrumb p; + Parser.endRegion p; + elseExpr | _ -> - parseElseBranch p - in - Parser.eatBreadcrumb p; - Parser.endRegion p; - elseExpr - | _ -> - Parser.endRegion p; - let startPos = p.Parser.startPos in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None + Parser.endRegion p; + let startPos = p.Parser.startPos in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None in let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.match_ ~attrs:[ifLetAttr; suppressFragileMatchWarningAttr] ~loc conditionExpr [ - Ast_helper.Exp.case pattern thenExpr; - Ast_helper.Exp.case (Ast_helper.Pat.any ()) elseExpr; - ] + Ast_helper.Exp.match_ + ~attrs:[ifLetAttr; suppressFragileMatchWarningAttr] + ~loc conditionExpr + [ + Ast_helper.Exp.case pattern thenExpr; + Ast_helper.Exp.case (Ast_helper.Pat.any ()) elseExpr; + ] and parseIfOrIfLetExpression p = Parser.beginRegion p; Parser.leaveBreadcrumb p Grammar.ExprIf; let startPos = p.Parser.startPos in Parser.expect If p; - let expr = match p.Parser.token with + let expr = + match p.Parser.token with | Let -> Parser.next p; let ifLetExpr = parseIfLetExpr startPos p in - Parser.err - ~startPos:ifLetExpr.pexp_loc.loc_start - ~endPos:ifLetExpr.pexp_loc.loc_end - p + Parser.err ~startPos:ifLetExpr.pexp_loc.loc_start + ~endPos:ifLetExpr.pexp_loc.loc_end p (Diagnostics.message (ErrorMessages.experimentalIfLet ifLetExpr)); ifLetExpr - | _ -> - parseIfExpr startPos p + | _ -> parseIfExpr startPos p in Parser.eatBreadcrumb p; - expr; + expr and parseForRest hasOpeningParen pattern startPos p = Parser.expect In p; let e1 = parseExpr p in - let direction = match p.Parser.token with - | Lident "to" -> Asttypes.Upto - | Lident "downto" -> Asttypes.Downto - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Asttypes.Upto + let direction = + match p.Parser.token with + | Lident "to" -> Asttypes.Upto + | Lident "downto" -> Asttypes.Downto + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Asttypes.Upto in Parser.next p; let e2 = parseExpr ~context:WhenExpr p in @@ -3263,46 +3405,45 @@ and parseForExpression p = Parser.leaveBreadcrumb p Grammar.ExprFor; Parser.expect For p; Parser.beginRegion p; - let forExpr = match p.token with - | Lparen -> - let lparen = p.startPos in - Parser.next p; - begin match p.token with - | Rparen -> + let forExpr = + match p.token with + | Lparen -> ( + let lparen = p.startPos in Parser.next p; - let unitPattern = - let loc = mkLoc lparen p.prevEndPos in - let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct lid None - in - parseForRest false (parseAliasPattern ~attrs:[] unitPattern p) startPos p + match p.token with + | Rparen -> + Parser.next p; + let unitPattern = + let loc = mkLoc lparen p.prevEndPos in + let lid = Location.mkloc (Longident.Lident "()") loc in + Ast_helper.Pat.construct lid None + in + parseForRest false + (parseAliasPattern ~attrs:[] unitPattern p) + startPos p + | _ -> ( + Parser.leaveBreadcrumb p Grammar.Pattern; + let pat = parsePattern p in + Parser.eatBreadcrumb p; + match p.token with + | Comma -> + Parser.next p; + let tuplePattern = + parseTuplePattern ~attrs:[] ~startPos:lparen ~first:pat p + in + let pattern = parseAliasPattern ~attrs:[] tuplePattern p in + parseForRest false pattern startPos p + | _ -> parseForRest true pat startPos p)) | _ -> Parser.leaveBreadcrumb p Grammar.Pattern; let pat = parsePattern p in Parser.eatBreadcrumb p; - begin match p.token with - | Comma -> - Parser.next p; - let tuplePattern = - parseTuplePattern ~attrs:[] ~startPos:lparen ~first:pat p - in - let pattern = parseAliasPattern ~attrs:[] tuplePattern p in - parseForRest false pattern startPos p - | _ -> - parseForRest true pat startPos p - end - end - | _ -> - Parser.leaveBreadcrumb p Grammar.Pattern; - let pat = parsePattern p in - Parser.eatBreadcrumb p; - parseForRest false pat startPos p + parseForRest false pat startPos p in Parser.eatBreadcrumb p; Parser.endRegion p; forExpr - and parseWhileExpression p = let startPos = p.Parser.startPos in Parser.expect While p; @@ -3315,11 +3456,10 @@ and parseWhileExpression p = and parsePatternGuard p = match p.Parser.token with - | When | If -> - Parser.next p; - Some (parseExpr ~context:WhenExpr p) - | _ -> - None + | When | If -> + Parser.next p; + Some (parseExpr ~context:WhenExpr p) + | _ -> None and parsePatternMatchCase p = Parser.beginRegion p; @@ -3331,9 +3471,10 @@ and parsePatternMatchCase p = let lhs = parsePattern p in Parser.eatBreadcrumb p; let guard = parsePatternGuard p in - let () = match p.token with - | EqualGreater -> Parser.next p - | _ -> Recover.recoverEqualGreater p + let () = + match p.token with + | EqualGreater -> Parser.next p + | _ -> Recover.recoverEqualGreater p in let rhs = parseExprBlock p in Parser.endRegion p; @@ -3346,17 +3487,15 @@ and parsePatternMatchCase p = and parsePatternMatching p = let cases = - parseDelimitedRegion - ~grammar:Grammar.PatternMatching - ~closing:Rbrace - ~f:parsePatternMatchCase - p + parseDelimitedRegion ~grammar:Grammar.PatternMatching ~closing:Rbrace + ~f:parsePatternMatchCase p in - let () = match cases with - | [] -> Parser.err ~startPos:p.prevEndPos p ( - Diagnostics.message "Pattern matching needs at least one case" - ) - | _ -> () + let () = + match cases with + | [] -> + Parser.err ~startPos:p.prevEndPos p + (Diagnostics.message "Pattern matching needs at least one case") + | _ -> () in cases @@ -3389,31 +3528,27 @@ and parseSwitchExpression p = * | . argument *) and parseArgument p = - if ( - p.Parser.token = Token.Tilde || - p.token = Dot || - p.token = Underscore || - Grammar.isExprStart p.token - ) then ( + if + p.Parser.token = Token.Tilde + || p.token = Dot || p.token = Underscore + || Grammar.isExprStart p.token + then match p.Parser.token with - | Dot -> + | Dot -> ( let uncurried = true in - Parser.next(p); - begin match p.token with - (* apply(.) *) - | Rparen -> - let unitExpr = Ast_helper.Exp.construct + Parser.next p; + match p.token with + (* apply(.) *) + | Rparen -> + let unitExpr = + Ast_helper.Exp.construct (Location.mknoloc (Longident.Lident "()")) None - in - Some (uncurried, Asttypes.Nolabel, unitExpr) - | _ -> - parseArgument2 p ~uncurried - end - | _ -> - parseArgument2 p ~uncurried:false - ) else - None + in + Some (uncurried, Asttypes.Nolabel, unitExpr) + | _ -> parseArgument2 p ~uncurried) + | _ -> parseArgument2 p ~uncurried:false + else None and parseArgument2 p ~uncurried = match p.Parser.token with @@ -3421,61 +3556,63 @@ and parseArgument2 p ~uncurried = | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> let loc = mkLoc p.startPos p.endPos in Parser.next p; - let exp = Ast_helper.Exp.ident ~loc ( - Location.mkloc (Longident.Lident "_") loc - ) in + let exp = + Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "_") loc) + in Some (uncurried, Asttypes.Nolabel, exp) - | Tilde -> + | Tilde -> ( Parser.next p; (* TODO: nesting of pattern matches not intuitive for error recovery *) - begin match p.Parser.token with - | Lident ident -> + match p.Parser.token with + | Lident ident -> ( let startPos = p.startPos in Parser.next p; let endPos = p.prevEndPos in let loc = mkLoc startPos endPos in - let propLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in - let identExpr = Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc ( - Location.mkloc (Longident.Lident ident) loc - ) in - begin match p.Parser.token with + let propLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + in + let identExpr = + Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc + (Location.mkloc (Longident.Lident ident) loc) + in + match p.Parser.token with | Question -> Parser.next p; Some (uncurried, Asttypes.Optional ident, identExpr) | Equal -> Parser.next p; - let label = match p.Parser.token with - | Question -> - Parser.next p; - Asttypes.Optional ident - | _ -> - Labelled ident + let label = + match p.Parser.token with + | Question -> + Parser.next p; + Asttypes.Optional ident + | _ -> Labelled ident in - let expr = match p.Parser.token with - | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Ast_helper.Exp.ident ~loc ( - Location.mkloc (Longident.Lident "_") loc - ) - | _ -> - let expr = parseConstrainedOrCoercedExpr p in - {expr with pexp_attributes = propLocAttr::expr.pexp_attributes} + let expr = + match p.Parser.token with + | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Ast_helper.Exp.ident ~loc + (Location.mkloc (Longident.Lident "_") loc) + | _ -> + let expr = parseConstrainedOrCoercedExpr p in + {expr with pexp_attributes = propLocAttr :: expr.pexp_attributes} in Some (uncurried, label, expr) | Colon -> Parser.next p; let typ = parseTypExpr p in let loc = mkLoc startPos p.prevEndPos in - let expr = Ast_helper.Exp.constraint_ ~attrs:[propLocAttr] ~loc identExpr typ in + let expr = + Ast_helper.Exp.constraint_ ~attrs:[propLocAttr] ~loc identExpr typ + in Some (uncurried, Labelled ident, expr) - | _ -> - Some (uncurried, Labelled ident, identExpr) - end + | _ -> Some (uncurried, Labelled ident, identExpr)) | t -> Parser.err p (Diagnostics.lident t); - Some (uncurried, Nolabel, Recover.defaultExpr ()) - end + Some (uncurried, Nolabel, Recover.defaultExpr ())) | _ -> Some (uncurried, Nolabel, parseConstrainedOrCoercedExpr p) and parseCallExpr p funExpr = @@ -3483,30 +3620,32 @@ and parseCallExpr p funExpr = let startPos = p.Parser.startPos in Parser.leaveBreadcrumb p Grammar.ExprCall; let args = - parseCommaDelimitedRegion - ~grammar:Grammar.ArgumentList - ~closing:Rparen + parseCommaDelimitedRegion ~grammar:Grammar.ArgumentList ~closing:Rparen ~f:parseArgument p in Parser.expect Rparen p; - let args = match args with - | [] -> - let loc = mkLoc startPos p.prevEndPos in - (* No args -> unit sugar: `foo()` *) - [ false, - Asttypes.Nolabel, - Ast_helper.Exp.construct - ~loc (Location.mkloc (Longident.Lident "()") loc) None + let args = + match args with + | [] -> + let loc = mkLoc startPos p.prevEndPos in + (* No args -> unit sugar: `foo()` *) + [ + ( false, + Asttypes.Nolabel, + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None ); + ] + | [ + ( true, + Asttypes.Nolabel, + ({ + pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None); + pexp_loc = loc; + pexp_attributes = []; + } as expr) ); ] - | [ - true, - Asttypes.Nolabel, - ({ - pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None); - pexp_loc = loc; - pexp_attributes = [] - } as expr) - ] when (not loc.loc_ghost) && p.mode = ParseForTypeChecker -> + when (not loc.loc_ghost) && p.mode = ParseForTypeChecker -> (* Since there is no syntax space for arity zero vs arity one, * we expand * `fn(. ())` into @@ -3519,43 +3658,47 @@ and parseCallExpr p funExpr = * * Related: https://github.com/rescript-lang/syntax/issues/138 *) - [ - true, - Asttypes.Nolabel, - Ast_helper.Exp.let_ - Asttypes.Nonrecursive - [Ast_helper.Vb.mk - (Ast_helper.Pat.var (Location.mknoloc "__res_unit")) - expr] - (Ast_helper.Exp.ident (Location.mknoloc (Longident.Lident "__res_unit"))) - ] - | args -> args + [ + ( true, + Asttypes.Nolabel, + Ast_helper.Exp.let_ Asttypes.Nonrecursive + [ + Ast_helper.Vb.mk + (Ast_helper.Pat.var (Location.mknoloc "__res_unit")) + expr; + ] + (Ast_helper.Exp.ident + (Location.mknoloc (Longident.Lident "__res_unit"))) ); + ] + | args -> args in let loc = {funExpr.pexp_loc with loc_end = p.prevEndPos} in - let args = match args with - | (u, lbl, expr)::args -> - let group (grp, acc) (uncurried, lbl, expr) = - let (_u, grp) = grp in - if uncurried == true then - ((true, [lbl, expr]), ((_u, (List.rev grp))::acc)) - else - ((_u, ((lbl, expr)::grp)), acc) - in - let ((_u, grp), acc) = List.fold_left group((u, [lbl, expr]), []) args in - List.rev ((_u, (List.rev grp))::acc) - | [] -> [] - in - let apply = List.fold_left (fun callBody group -> - let (uncurried, args) = group in - let (args, wrap) = processUnderscoreApplication args in - let exp = if uncurried then - let attrs = [uncurryAttr] in - Ast_helper.Exp.apply ~loc ~attrs callBody args - else - Ast_helper.Exp.apply ~loc callBody args - in - wrap exp - ) funExpr args + let args = + match args with + | (u, lbl, expr) :: args -> + let group (grp, acc) (uncurried, lbl, expr) = + let _u, grp = grp in + if uncurried == true then + ((true, [(lbl, expr)]), (_u, List.rev grp) :: acc) + else ((_u, (lbl, expr) :: grp), acc) + in + let (_u, grp), acc = List.fold_left group ((u, [(lbl, expr)]), []) args in + List.rev ((_u, List.rev grp) :: acc) + | [] -> [] + in + let apply = + List.fold_left + (fun callBody group -> + let uncurried, args = group in + let args, wrap = processUnderscoreApplication args in + let exp = + if uncurried then + let attrs = [uncurryAttr] in + Ast_helper.Exp.apply ~loc ~attrs callBody args + else Ast_helper.Exp.apply ~loc callBody args + in + wrap exp) + funExpr args in Parser.eatBreadcrumb p; apply @@ -3564,122 +3707,120 @@ and parseValueOrConstructor p = let startPos = p.Parser.startPos in let rec aux p acc = match p.Parser.token with - | Uident ident -> + | Uident ident -> ( let endPosLident = p.endPos in Parser.next p; - begin match p.Parser.token with + match p.Parser.token with | Dot -> Parser.next p; - aux p (ident::acc) + aux p (ident :: acc) | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> let lparen = p.startPos in let args = parseConstructorArgs p in let rparen = p.prevEndPos in - let lident = buildLongident (ident::acc) in - let tail = match args with - | [] -> None - | [{Parsetree.pexp_desc = Pexp_tuple _} as arg] as args -> - let loc = mkLoc lparen rparen in - if p.mode = ParseForTypeChecker then - (* Some(1, 2) for type-checker *) - Some arg - else - (* Some((1, 2)) for printer *) + let lident = buildLongident (ident :: acc) in + let tail = + match args with + | [] -> None + | [({Parsetree.pexp_desc = Pexp_tuple _} as arg)] as args -> + let loc = mkLoc lparen rparen in + if p.mode = ParseForTypeChecker then + (* Some(1, 2) for type-checker *) + Some arg + else + (* Some((1, 2)) for printer *) + Some (Ast_helper.Exp.tuple ~loc args) + | [arg] -> Some arg + | args -> + let loc = mkLoc lparen rparen in Some (Ast_helper.Exp.tuple ~loc args) - | [arg] -> - Some arg - | args -> - let loc = mkLoc lparen rparen in - Some (Ast_helper.Exp.tuple ~loc args) in let loc = mkLoc startPos p.prevEndPos in let identLoc = mkLoc startPos endPosLident in Ast_helper.Exp.construct ~loc (Location.mkloc lident identLoc) tail | _ -> let loc = mkLoc startPos p.prevEndPos in - let lident = buildLongident (ident::acc) in - Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) None - end + let lident = buildLongident (ident :: acc) in + Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) None) | Lident ident -> Parser.next p; let loc = mkLoc startPos p.prevEndPos in - let lident = buildLongident (ident::acc) in + let lident = buildLongident (ident :: acc) in Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) | token -> if acc = [] then ( Parser.next p; Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultExpr() - ) else ( + Recover.defaultExpr ()) + else let loc = mkLoc startPos p.prevEndPos in Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - let lident = buildLongident ("_"::acc) in + let lident = buildLongident ("_" :: acc) in Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) - ) in aux p [] and parsePolyVariantExpr p = let startPos = p.startPos in - let (ident, _loc) = parseHashIdent ~startPos p in - begin match p.Parser.token with + let ident, _loc = parseHashIdent ~startPos p in + match p.Parser.token with | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> let lparen = p.startPos in let args = parseConstructorArgs p in let rparen = p.prevEndPos in let loc_paren = mkLoc lparen rparen in - let tail = match args with - | [] -> None - | [{Parsetree.pexp_desc = Pexp_tuple _} as expr ] as args -> - if p.mode = ParseForTypeChecker then - (* #a(1, 2) for type-checker *) - Some expr - else - (* #a((1, 2)) for type-checker *) + let tail = + match args with + | [] -> None + | [({Parsetree.pexp_desc = Pexp_tuple _} as expr)] as args -> + if p.mode = ParseForTypeChecker then + (* #a(1, 2) for type-checker *) + Some expr + else + (* #a((1, 2)) for type-checker *) + Some (Ast_helper.Exp.tuple ~loc:loc_paren args) + | [arg] -> Some arg + | args -> + (* #a((1, 2)) for printer *) Some (Ast_helper.Exp.tuple ~loc:loc_paren args) - | [arg] -> Some arg - | args -> - (* #a((1, 2)) for printer *) - Some (Ast_helper.Exp.tuple ~loc:loc_paren args) in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.variant ~loc ident tail | _ -> let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.variant ~loc ident None - end and parseConstructorArgs p = let lparen = p.Parser.startPos in Parser.expect Lparen p; let args = - parseCommaDelimitedRegion - ~grammar:Grammar.ExprList ~f:parseConstrainedExprRegion ~closing:Rparen p + parseCommaDelimitedRegion ~grammar:Grammar.ExprList + ~f:parseConstrainedExprRegion ~closing:Rparen p in Parser.expect Rparen p; match args with | [] -> let loc = mkLoc lparen p.prevEndPos in - [Ast_helper.Exp.construct - ~loc (Location.mkloc (Longident.Lident "()") loc) None] + [ + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None; + ] | args -> args and parseTupleExpr ~first ~startPos p = let exprs = - first::( - parseCommaDelimitedRegion - p - ~grammar:Grammar.ExprList - ~closing:Rparen - ~f:parseConstrainedExprRegion - ) + first + :: parseCommaDelimitedRegion p ~grammar:Grammar.ExprList ~closing:Rparen + ~f:parseConstrainedExprRegion in Parser.expect Rparen p; - let () = match exprs with - | [_] -> - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.tupleSingleElement) - | _ -> () + let () = + match exprs with + | [_] -> + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.tupleSingleElement) + | _ -> () in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.tuple ~loc exprs @@ -3696,55 +3837,52 @@ and parseSpreadExprRegion p = and parseListExpr ~startPos p = let listExprs = - parseCommaDelimitedReversedList - p ~grammar:Grammar.ListExpr ~closing:Rbrace ~f:parseSpreadExprRegion + parseCommaDelimitedReversedList p ~grammar:Grammar.ListExpr ~closing:Rbrace + ~f:parseSpreadExprRegion in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in match listExprs with - | (true, expr)::exprs -> + | (true, expr) :: exprs -> let exprs = exprs |> List.map snd |> List.rev in makeListExpression loc exprs (Some expr) | exprs -> - let exprs = + let exprs = exprs |> List.map (fun (spread, expr) -> - if spread then - Parser.err p (Diagnostics.message ErrorMessages.listExprSpread); - expr) + if spread then + Parser.err p (Diagnostics.message ErrorMessages.listExprSpread); + expr) |> List.rev in makeListExpression loc exprs None (* Overparse ... and give a nice error message *) and parseNonSpreadExp ~msg p = - let () = match p.Parser.token with - | DotDotDot -> - Parser.err p (Diagnostics.message msg); - Parser.next p; - | _ -> () + let () = + match p.Parser.token with + | DotDotDot -> + Parser.err p (Diagnostics.message msg); + Parser.next p + | _ -> () in match p.Parser.token with - | token when Grammar.isExprStart token -> + | token when Grammar.isExprStart token -> ( let expr = parseExpr p in - begin match p.Parser.token with + match p.Parser.token with | Colon -> Parser.next p; let typ = parseTypExpr p in let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in Some (Ast_helper.Exp.constraint_ ~loc expr typ) - | _ -> Some expr - end + | _ -> Some expr) | _ -> None and parseArrayExp p = let startPos = p.Parser.startPos in Parser.expect Lbracket p; let exprs = - parseCommaDelimitedRegion - p - ~grammar:Grammar.ExprList - ~closing:Rbracket + parseCommaDelimitedRegion p ~grammar:Grammar.ExprList ~closing:Rbracket ~f:(parseNonSpreadExp ~msg:ErrorMessages.arrayExprSpread) in Parser.expect Rbracket p; @@ -3755,16 +3893,16 @@ and parseArrayExp p = and parsePolyTypeExpr p = let startPos = p.Parser.startPos in match p.Parser.token with - | SingleQuote -> + | SingleQuote -> ( let vars = parseTypeVarList p in - begin match vars with - | _v1::_v2::_ -> + match vars with + | _v1 :: _v2 :: _ -> Parser.expect Dot p; let typ = parseTypExpr p in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Typ.poly ~loc vars typ - | [var] -> - begin match p.Parser.token with + | [var] -> ( + match p.Parser.token with | Dot -> Parser.next p; let typ = parseTypExpr p in @@ -3776,13 +3914,9 @@ and parsePolyTypeExpr p = let returnType = parseTypExpr ~alias:false p in let loc = mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos in Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType - | _ -> - Ast_helper.Typ.var ~loc:var.loc var.txt - end - | _ -> assert false - end - | _ -> - parseTypExpr p + | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt) + | _ -> assert false) + | _ -> parseTypExpr p (* 'a 'b 'c *) and parseTypeVarList p = @@ -3790,11 +3924,10 @@ and parseTypeVarList p = match p.Parser.token with | SingleQuote -> Parser.next p; - let (lident, loc) = parseLident p in + let lident, loc = parseLident p in let var = Location.mkloc lident loc in - loop p (var::vars) - | _ -> - List.rev vars + loop p (var :: vars) + | _ -> List.rev vars in loop p [] @@ -3804,72 +3937,75 @@ and parseLidentList p = | Lident lident -> let loc = mkLoc p.startPos p.endPos in Parser.next p; - loop p ((Location.mkloc lident loc)::ls) - | _ -> - List.rev ls + loop p (Location.mkloc lident loc :: ls) + | _ -> List.rev ls in loop p [] and parseAtomicTypExpr ~attrs p = Parser.leaveBreadcrumb p Grammar.AtomicTypExpr; let startPos = p.Parser.startPos in - let typ = match p.Parser.token with - | SingleQuote -> - Parser.next p; - let (ident, loc) = parseIdent ~msg:ErrorMessages.typeVar ~startPos:p.startPos p in - Ast_helper.Typ.var ~loc ~attrs ident - | Underscore -> - let endPos = p.endPos in - Parser.next p; - Ast_helper.Typ.any ~loc:(mkLoc startPos endPos) ~attrs () - | Lparen -> - Parser.next p; - begin match p.Parser.token with - | Rparen -> + let typ = + match p.Parser.token with + | SingleQuote -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let unitConstr = Location.mkloc (Longident.Lident "unit") loc in - Ast_helper.Typ.constr ~attrs unitConstr [] - | _ -> - let t = parseTypExpr p in - begin match p.token with - | Comma -> + let ident, loc = + parseIdent ~msg:ErrorMessages.typeVar ~startPos:p.startPos p + in + Ast_helper.Typ.var ~loc ~attrs ident + | Underscore -> + let endPos = p.endPos in + Parser.next p; + Ast_helper.Typ.any ~loc:(mkLoc startPos endPos) ~attrs () + | Lparen -> ( + Parser.next p; + match p.Parser.token with + | Rparen -> Parser.next p; - parseTupleType ~attrs ~first:t ~startPos p - | _ -> - Parser.expect Rparen p; - {t with - ptyp_loc = mkLoc startPos p.prevEndPos; - ptyp_attributes = List.concat [attrs; t.ptyp_attributes]} - end - end - | Lbracket -> - parsePolymorphicVariantType ~attrs p - | Uident _ | Lident _ -> - let constr = parseValuePath p in - let args = parseTypeConstructorArgs ~constrName:constr p in - Ast_helper.Typ.constr ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args - | Module -> - Parser.next p; - Parser.expect Lparen p; - let packageType = parsePackageType ~startPos ~attrs p in - Parser.expect Rparen p; - {packageType with ptyp_loc = mkLoc startPos p.prevEndPos} - | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.extension ~attrs ~loc extension - | Lbrace -> - parseRecordOrObjectType ~attrs p - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - begin match skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicTypExprStart with - | Some () -> - parseAtomicTypExpr ~attrs p - | None -> - Parser.err ~startPos:p.prevEndPos p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultType() - end + let loc = mkLoc startPos p.prevEndPos in + let unitConstr = Location.mkloc (Longident.Lident "unit") loc in + Ast_helper.Typ.constr ~attrs unitConstr [] + | _ -> ( + let t = parseTypExpr p in + match p.token with + | Comma -> + Parser.next p; + parseTupleType ~attrs ~first:t ~startPos p + | _ -> + Parser.expect Rparen p; + { + t with + ptyp_loc = mkLoc startPos p.prevEndPos; + ptyp_attributes = List.concat [attrs; t.ptyp_attributes]; + })) + | Lbracket -> parsePolymorphicVariantType ~attrs p + | Uident _ | Lident _ -> + let constr = parseValuePath p in + let args = parseTypeConstructorArgs ~constrName:constr p in + Ast_helper.Typ.constr + ~loc:(mkLoc startPos p.prevEndPos) + ~attrs constr args + | Module -> + Parser.next p; + Parser.expect Lparen p; + let packageType = parsePackageType ~startPos ~attrs p in + Parser.expect Rparen p; + {packageType with ptyp_loc = mkLoc startPos p.prevEndPos} + | Percent -> + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.extension ~attrs ~loc extension + | Lbrace -> parseRecordOrObjectType ~attrs p + | token -> ( + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + match + skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicTypExprStart + with + | Some () -> parseAtomicTypExpr ~attrs p + | None -> + Parser.err ~startPos:p.prevEndPos p + (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultType ()) in Parser.eatBreadcrumb p; typ @@ -3877,10 +4013,10 @@ and parseAtomicTypExpr ~attrs p = (* package-type ::= | modtype-path ∣ modtype-path with package-constraint { and package-constraint } - *) +*) and parsePackageType ~startPos ~attrs p = let modTypePath = parseModuleLongIdent ~lowercase:true p in - begin match p.Parser.token with + match p.Parser.token with | Lident "with" -> Parser.next p; let constraints = parsePackageConstraints p in @@ -3889,7 +4025,6 @@ and parsePackageType ~startPos ~attrs p = | _ -> let loc = mkLoc startPos p.prevEndPos in Ast_helper.Typ.package ~loc ~attrs modTypePath [] - end (* package-constraint { and package-constraint } *) and parsePackageConstraints p = @@ -3900,12 +4035,10 @@ and parsePackageConstraints p = let typ = parseTypExpr p in (typeConstr, typ) in - let rest = parseRegion - ~grammar:Grammar.PackageConstraint - ~f:parsePackageConstraint - p + let rest = + parseRegion ~grammar:Grammar.PackageConstraint ~f:parsePackageConstraint p in - first::rest + first :: rest (* and type typeconstr = typexpr *) and parsePackageConstraint p = @@ -3923,30 +4056,35 @@ and parseRecordOrObjectType ~attrs p = (* for inline record in constructor *) let startPos = p.Parser.startPos in Parser.expect Lbrace p; - let closedFlag = match p.token with - | DotDot -> Parser.next p; Asttypes.Open - | Dot -> Parser.next p; Asttypes.Closed - | _ -> Asttypes.Closed + let closedFlag = + match p.token with + | DotDot -> + Parser.next p; + Asttypes.Open + | Dot -> + Parser.next p; + Asttypes.Closed + | _ -> Asttypes.Closed in - let () = match p.token with - | Lident _ -> - Parser.err p (Diagnostics.message ErrorMessages.forbiddenInlineRecordDeclaration) - | _ -> () + let () = + match p.token with + | Lident _ -> + Parser.err p + (Diagnostics.message ErrorMessages.forbiddenInlineRecordDeclaration) + | _ -> () in let startFirstField = p.startPos in let fields = - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p + parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parseStringFieldDeclaration p in - let () = match fields with - | [Parsetree.Oinherit {ptyp_loc}] -> - (* {...x}, spread without extra fields *) - Parser.err p ~startPos:startFirstField ~endPos:ptyp_loc.loc_end - (Diagnostics.message ErrorMessages.sameTypeSpread) - | _ -> () + let () = + match fields with + | [Parsetree.Oinherit {ptyp_loc}] -> + (* {...x}, spread without extra fields *) + Parser.err p ~startPos:startFirstField ~endPos:ptyp_loc.loc_end + (Diagnostics.message ErrorMessages.sameTypeSpread) + | _ -> () in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in @@ -3958,87 +4096,90 @@ and parseTypeAlias p typ = | As -> Parser.next p; Parser.expect SingleQuote p; - let (ident, _loc) = parseLident p in + let ident, _loc = parseLident p in (* TODO: how do we parse attributes here? *) - Ast_helper.Typ.alias ~loc:(mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos) typ ident + Ast_helper.Typ.alias + ~loc:(mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos) + typ ident | _ -> typ - (* type_parameter ::= - * | type_expr - * | ~ident: type_expr - * | ~ident: type_expr=? - * - * note: - * | attrs ~ident: type_expr -> attrs are on the arrow - * | attrs type_expr -> attrs are here part of the type_expr - * - * uncurried_type_parameter ::= - * | . type_parameter - *) + * | type_expr + * | ~ident: type_expr + * | ~ident: type_expr=? + * + * note: + * | attrs ~ident: type_expr -> attrs are on the arrow + * | attrs type_expr -> attrs are here part of the type_expr + * + * uncurried_type_parameter ::= + * | . type_parameter +*) and parseTypeParameter p = - if ( - p.Parser.token = Token.Tilde || - p.token = Dot || - Grammar.isTypExprStart p.token - ) then ( + if + p.Parser.token = Token.Tilde + || p.token = Dot + || Grammar.isTypExprStart p.token + then let startPos = p.Parser.startPos in let uncurried = Parser.optional p Dot in let attrs = parseAttributes p in match p.Parser.token with - | Tilde -> + | Tilde -> ( Parser.next p; - let (name, loc) = parseLident p in - let lblLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in + let name, loc = parseLident p in + let lblLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + in Parser.expect ~grammar:Grammar.TypeExpression Colon p; let typ = let typ = parseTypExpr p in - {typ with ptyp_attributes = lblLocAttr::typ.ptyp_attributes} + {typ with ptyp_attributes = lblLocAttr :: typ.ptyp_attributes} in - begin match p.Parser.token with + match p.Parser.token with | Equal -> Parser.next p; Parser.expect Question p; Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) - | _ -> - Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos) - end - | Lident _ -> - let (name, loc) = parseLident p in - begin match p.token with - | Colon -> + | _ -> Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos)) + | Lident _ -> ( + let name, loc = parseLident p in + match p.token with + | Colon -> ( let () = - let error = Diagnostics.message ( - ErrorMessages.missingTildeLabeledParameter name - ) in + let error = + Diagnostics.message + (ErrorMessages.missingTildeLabeledParameter name) + in Parser.err ~startPos:loc.loc_start ~endPos:loc.loc_end p error in Parser.next p; let typ = parseTypExpr p in - begin match p.Parser.token with + match p.Parser.token with | Equal -> Parser.next p; Parser.expect Question p; Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) - | _ -> - Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos) - end + | _ -> Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos)) | _ -> let constr = Location.mkloc (Longident.Lident name) loc in - let args = parseTypeConstructorArgs ~constrName:constr p in - let typ = Ast_helper.Typ.constr ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args + let args = parseTypeConstructorArgs ~constrName:constr p in + let typ = + Ast_helper.Typ.constr + ~loc:(mkLoc startPos p.prevEndPos) + ~attrs constr args in let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in let typ = parseTypeAlias p typ in - Some (uncurried, [], Asttypes.Nolabel, typ, startPos) - end + Some (uncurried, [], Asttypes.Nolabel, typ, startPos)) | _ -> let typ = parseTypExpr p in - let typWithAttributes = {typ with ptyp_attributes = List.concat[attrs; typ.ptyp_attributes]} in + let typWithAttributes = + {typ with ptyp_attributes = List.concat [attrs; typ.ptyp_attributes]} + in Some (uncurried, [], Asttypes.Nolabel, typWithAttributes, startPos) - ) else - None + else None (* (int, ~x:string, float) *) and parseTypeParameters p = @@ -4053,7 +4194,8 @@ and parseTypeParameters p = [(false, [], Asttypes.Nolabel, typ, startPos)] | _ -> let params = - parseCommaDelimitedRegion ~grammar:Grammar.TypeParameters ~closing:Rparen ~f:parseTypeParameter p + parseCommaDelimitedRegion ~grammar:Grammar.TypeParameters ~closing:Rparen + ~f:parseTypeParameter p in Parser.expect Rparen p; params @@ -4063,20 +4205,20 @@ and parseEs6ArrowType ~attrs p = match p.Parser.token with | Tilde -> Parser.next p; - let (name, loc) = parseLident p in + let name, loc = parseLident p in let lblLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in Parser.expect ~grammar:Grammar.TypeExpression Colon p; let typ = let typ = parseTypExpr ~alias:false ~es6Arrow:false p in - {typ with ptyp_attributes = lblLocAttr::typ.ptyp_attributes} + {typ with ptyp_attributes = lblLocAttr :: typ.ptyp_attributes} in - let arg = match p.Parser.token with - | Equal -> - Parser.next p; - Parser.expect Question p; - Asttypes.Optional name - | _ -> - Asttypes.Labelled name + let arg = + match p.Parser.token with + | Equal -> + Parser.next p; + Parser.expect Question p; + Asttypes.Optional name + | _ -> Asttypes.Labelled name in Parser.expect EqualGreater p; let returnType = parseTypExpr ~alias:false p in @@ -4087,14 +4229,18 @@ and parseEs6ArrowType ~attrs p = Parser.expect EqualGreater p; let returnType = parseTypExpr ~alias:false p in let endPos = p.prevEndPos in - let typ = List.fold_right (fun (uncurried, attrs, argLbl, typ, startPos) t -> - let attrs = if uncurried then uncurryAttr::attrs else attrs in - Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ t - ) parameters returnType + let typ = + List.fold_right + (fun (uncurried, attrs, argLbl, typ, startPos) t -> + let attrs = if uncurried then uncurryAttr :: attrs else attrs in + Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ t) + parameters returnType in - {typ with + { + typ with ptyp_attributes = List.concat [typ.ptyp_attributes; attrs]; - ptyp_loc = mkLoc startPos p.prevEndPos} + ptyp_loc = mkLoc startPos p.prevEndPos; + } (* * typexpr ::= @@ -4116,19 +4262,19 @@ and parseEs6ArrowType ~attrs p = * | uident.lident * | uident.uident.lident --> long module path *) -and parseTypExpr ?attrs ?(es6Arrow=true) ?(alias=true) p = +and parseTypExpr ?attrs ?(es6Arrow = true) ?(alias = true) p = (* Parser.leaveBreadcrumb p Grammar.TypeExpression; *) let startPos = p.Parser.startPos in - let attrs = match attrs with - | Some attrs -> - attrs - | None -> - parseAttributes p in - let typ = if es6Arrow && isEs6ArrowType p then - parseEs6ArrowType ~attrs p - else - let typ = parseAtomicTypExpr ~attrs p in - parseArrowTypeRest ~es6Arrow ~startPos typ p + let attrs = + match attrs with + | Some attrs -> attrs + | None -> parseAttributes p + in + let typ = + if es6Arrow && isEs6ArrowType p then parseEs6ArrowType ~attrs p + else + let typ = parseAtomicTypExpr ~attrs p in + parseArrowTypeRest ~es6Arrow ~startPos typ p in let typ = if alias then parseTypeAlias p typ else typ in (* Parser.eatBreadcrumb p; *) @@ -4138,9 +4284,7 @@ and parseArrowTypeRest ~es6Arrow ~startPos typ p = match p.Parser.token with | (EqualGreater | MinusGreater) as token when es6Arrow == true -> (* error recovery *) - if token = MinusGreater then ( - Parser.expect EqualGreater p; - ); + if token = MinusGreater then Parser.expect EqualGreater p; Parser.next p; let returnType = parseTypExpr ~alias:false p in let loc = mkLoc startPos p.prevEndPos in @@ -4148,39 +4292,31 @@ and parseArrowTypeRest ~es6Arrow ~startPos typ p = | _ -> typ and parseTypExprRegion p = - if Grammar.isTypExprStart p.Parser.token then - Some (parseTypExpr p) - else - None + if Grammar.isTypExprStart p.Parser.token then Some (parseTypExpr p) else None and parseTupleType ~attrs ~first ~startPos p = let typexprs = - first::( - parseCommaDelimitedRegion - ~grammar:Grammar.TypExprList - ~closing:Rparen - ~f:parseTypExprRegion - p - ) + first + :: parseCommaDelimitedRegion ~grammar:Grammar.TypExprList ~closing:Rparen + ~f:parseTypExprRegion p in Parser.expect Rparen p; - let () = match typexprs with - | [_] -> - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.tupleSingleElement) - | _ -> () + let () = + match typexprs with + | [_] -> + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.tupleSingleElement) + | _ -> () in let tupleLoc = mkLoc startPos p.prevEndPos in Ast_helper.Typ.tuple ~attrs ~loc:tupleLoc typexprs and parseTypeConstructorArgRegion p = - if Grammar.isTypExprStart p.Parser.token then - Some (parseTypExpr p) + if Grammar.isTypExprStart p.Parser.token then Some (parseTypExpr p) else if p.token = LessThan then ( Parser.next p; - parseTypeConstructorArgRegion p - ) else - None + parseTypeConstructorArgRegion p) + else None (* Js.Nullable.value<'a> *) and parseTypeConstructorArgs ~constrName p = @@ -4192,32 +4328,27 @@ and parseTypeConstructorArgs ~constrName p = Parser.next p; let typeArgs = (* TODO: change Grammar.TypExprList to TypArgList!!! Why did I wrote this? *) - parseCommaDelimitedRegion - ~grammar:Grammar.TypExprList - ~closing:GreaterThan - ~f:parseTypeConstructorArgRegion - p + parseCommaDelimitedRegion ~grammar:Grammar.TypExprList + ~closing:GreaterThan ~f:parseTypeConstructorArgRegion p in - let () = match p.token with - | Rparen when opening = Token.Lparen -> - let typ = Ast_helper.Typ.constr constrName typeArgs in - let msg = - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.text "Type parameters require angle brackets:"; - Doc.indent ( - Doc.concat [ - Doc.line; - ResPrinter.printTypExpr typ CommentTable.empty; - ] - ) - ] - ) |> Doc.toString ~width:80 - in - Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); - Parser.next p - | _ -> - Parser.expect GreaterThan p + let () = + match p.token with + | Rparen when opening = Token.Lparen -> + let typ = Ast_helper.Typ.constr constrName typeArgs in + let msg = + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "Type parameters require angle brackets:"; + Doc.indent + (Doc.concat + [Doc.line; ResPrinter.printTypExpr typ CommentTable.empty]); + ]) + |> Doc.toString ~width:80 + in + Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); + Parser.next p + | _ -> Parser.expect GreaterThan p in Scanner.popMode p.scanner Diamond; typeArgs @@ -4236,21 +4367,21 @@ and parseStringFieldDeclaration p = let fieldName = Location.mkloc name (mkLoc nameStartPos nameEndPos) in Parser.expect ~grammar:Grammar.TypeExpression Colon p; let typ = parsePolyTypeExpr p in - Some(Parsetree.Otag (fieldName, attrs, typ)) + Some (Parsetree.Otag (fieldName, attrs, typ)) | DotDotDot -> Parser.next p; let typ = parseTypExpr p in - Some(Parsetree.Oinherit typ) + Some (Parsetree.Oinherit typ) | Lident name -> let nameLoc = mkLoc p.startPos p.endPos in - Parser.err p (Diagnostics.message (ErrorMessages.objectQuotedFieldName name)); + Parser.err p + (Diagnostics.message (ErrorMessages.objectQuotedFieldName name)); Parser.next p; let fieldName = Location.mkloc name nameLoc in Parser.expect ~grammar:Grammar.TypeExpression Colon p; let typ = parsePolyTypeExpr p in - Some(Parsetree.Otag (fieldName, attrs, typ)) - | _token -> - None + Some (Parsetree.Otag (fieldName, attrs, typ)) + | _token -> None (* field-decl ::= * | [mutable] field-name : poly-typexpr @@ -4258,49 +4389,48 @@ and parseStringFieldDeclaration p = and parseFieldDeclaration p = let startPos = p.Parser.startPos in let attrs = parseAttributes p in - let mut = if Parser.optional p Token.Mutable then - Asttypes.Mutable - else - Asttypes.Immutable + let mut = + if Parser.optional p Token.Mutable then Asttypes.Mutable + else Asttypes.Immutable in - let (lident, loc) = match p.token with - | _ -> parseLident p + let lident, loc = + match p.token with + | _ -> parseLident p in let name = Location.mkloc lident loc in - let typ = match p.Parser.token with - | Colon -> - Parser.next p; - parsePolyTypeExpr p - | _ -> - Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] + let typ = + match p.Parser.token with + | Colon -> + Parser.next p; + parsePolyTypeExpr p + | _ -> + Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] in let loc = mkLoc startPos typ.ptyp_loc.loc_end in Ast_helper.Type.field ~attrs ~loc ~mut name typ - and parseFieldDeclarationRegion p = let startPos = p.Parser.startPos in let attrs = parseAttributes p in - let mut = if Parser.optional p Token.Mutable then - Asttypes.Mutable - else - Asttypes.Immutable + let mut = + if Parser.optional p Token.Mutable then Asttypes.Mutable + else Asttypes.Immutable in match p.token with | Lident _ -> - let (lident, loc) = parseLident p in + let lident, loc = parseLident p in let name = Location.mkloc lident loc in - let typ = match p.Parser.token with - | Colon -> - Parser.next p; - parsePolyTypeExpr p - | _ -> - Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] + let typ = + match p.Parser.token with + | Colon -> + Parser.next p; + parsePolyTypeExpr p + | _ -> + Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] in let loc = mkLoc startPos typ.ptyp_loc.loc_end in - Some(Ast_helper.Type.field ~attrs ~loc ~mut name typ) - | _ -> - None + Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) + | _ -> None (* record-decl ::= * | { field-decl } @@ -4311,11 +4441,8 @@ and parseRecordDeclaration p = Parser.leaveBreadcrumb p Grammar.RecordDecl; Parser.expect Lbrace p; let rows = - parseCommaDelimitedRegion - ~grammar:Grammar.RecordDecl - ~closing:Rbrace - ~f:parseFieldDeclarationRegion - p + parseCommaDelimitedRegion ~grammar:Grammar.RecordDecl ~closing:Rbrace + ~f:parseFieldDeclarationRegion p in Parser.expect Rbrace p; Parser.eatBreadcrumb p; @@ -4331,124 +4458,121 @@ and parseRecordDeclaration p = * Give a good error message afterwards? *) and parseConstrDeclArgs p = - let constrArgs = match p.Parser.token with - | Lparen -> - Parser.next p; - (* TODO: this could use some cleanup/stratification *) - begin match p.Parser.token with - | Lbrace -> - let lbrace = p.startPos in + let constrArgs = + match p.Parser.token with + | Lparen -> ( Parser.next p; - let startPos = p.Parser.startPos in - begin match p.Parser.token with - | DotDot | Dot -> - let closedFlag = match p.token with - | DotDot -> Parser.next p; Asttypes.Open - | Dot -> Parser.next p; Asttypes.Closed - | _ -> Asttypes.Closed - in - let fields = - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag in - Parser.optional p Comma |> ignore; - let moreArgs = - parseCommaDelimitedRegion - ~grammar:Grammar.TypExprList - ~closing:Rparen - ~f:parseTypExprRegion - p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ::moreArgs) - | DotDotDot -> - let dotdotdotStart = p.startPos in - let dotdotdotEnd = p.endPos in - (* start of object type spreading, e.g. `User({...a, "u": int})` *) + (* TODO: this could use some cleanup/stratification *) + match p.Parser.token with + | Lbrace -> ( + let lbrace = p.startPos in Parser.next p; - let typ = parseTypExpr p in - let () = match p.token with - | Rbrace -> - (* {...x}, spread without extra fields *) - Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p - (Diagnostics.message ErrorMessages.sameTypeSpread); + let startPos = p.Parser.startPos in + match p.Parser.token with + | DotDot | Dot -> + let closedFlag = + match p.token with + | DotDot -> + Parser.next p; + Asttypes.Open + | Dot -> + Parser.next p; + Asttypes.Closed + | _ -> Asttypes.Closed + in + let fields = + parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parseStringFieldDeclaration p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag in + Parser.optional p Comma |> ignore; + let moreArgs = + parseCommaDelimitedRegion ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parseTypExprRegion p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ :: moreArgs) + | DotDotDot -> + let dotdotdotStart = p.startPos in + let dotdotdotEnd = p.endPos in + (* start of object type spreading, e.g. `User({...a, "u": int})` *) Parser.next p; - | _ -> Parser.expect Comma p - in - let () = match p.token with - | Lident _ -> - Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p - (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) - | _ -> () - in - let fields = - (Parsetree.Oinherit typ)::( - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p - ) - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - Ast_helper.Typ.object_ ~loc fields Asttypes.Closed |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - Parser.optional p Comma |> ignore; - let moreArgs = - parseCommaDelimitedRegion - ~grammar:Grammar.TypExprList - ~closing:Rparen - ~f:parseTypExprRegion p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ::moreArgs) - | _ -> - let attrs = parseAttributes p in - begin match p.Parser.token with - | String _ -> - let closedFlag = Asttypes.Closed in - let fields = match attrs with - | [] -> - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p - | attrs -> - let first = - Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; - let field = match parseStringFieldDeclaration p with - | Some field -> field - | None -> assert false - in - (* parse comma after first *) - let () = match p.Parser.token with - | Rbrace | Eof -> () - | Comma -> Parser.next p - | _ -> Parser.expect Comma p - in - Parser.eatBreadcrumb p; - begin match field with - | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct) - | Oinherit ct -> Oinherit ct - end + let typ = parseTypExpr p in + let () = + match p.token with + | Rbrace -> + (* {...x}, spread without extra fields *) + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.sameTypeSpread); + Parser.next p + | _ -> Parser.expect Comma p + in + let () = + match p.token with + | Lident _ -> + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) + | _ -> () + in + let fields = + Parsetree.Oinherit typ + :: parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parseStringFieldDeclaration p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc fields Asttypes.Closed + |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + Parser.optional p Comma |> ignore; + let moreArgs = + parseCommaDelimitedRegion ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parseTypExprRegion p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ :: moreArgs) + | _ -> ( + let attrs = parseAttributes p in + match p.Parser.token with + | String _ -> + let closedFlag = Asttypes.Closed in + let fields = + match attrs with + | [] -> + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parseStringFieldDeclaration p + | attrs -> + let first = + Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; + let field = + match parseStringFieldDeclaration p with + | Some field -> field + | None -> assert false + in + (* parse comma after first *) + let () = + match p.Parser.token with + | Rbrace | Eof -> () + | Comma -> Parser.next p + | _ -> Parser.expect Comma p + in + Parser.eatBreadcrumb p; + match field with + | Parsetree.Otag (label, _, ct) -> + Parsetree.Otag (label, attrs, ct) + | Oinherit ct -> Oinherit ct + in + first + :: parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parseStringFieldDeclaration p in - first::( - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p - ) in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in let typ = @@ -4458,65 +4582,54 @@ and parseConstrDeclArgs p = let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in Parser.optional p Comma |> ignore; let moreArgs = - parseCommaDelimitedRegion - ~grammar:Grammar.TypExprList - ~closing:Rparen - ~f:parseTypExprRegion p + parseCommaDelimitedRegion ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parseTypExprRegion p in Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ::moreArgs) + Parsetree.Pcstr_tuple (typ :: moreArgs) | _ -> - let fields = match attrs with - | [] -> - parseCommaDelimitedRegion - ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace - ~f:parseFieldDeclarationRegion - p - | attrs -> - let first = - let field = parseFieldDeclaration p in - Parser.expect Comma p; - {field with Parsetree.pld_attributes = attrs} - in - first::( - parseCommaDelimitedRegion - ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace - ~f:parseFieldDeclarationRegion - p - ) + let fields = + match attrs with + | [] -> + parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace ~f:parseFieldDeclarationRegion p + | attrs -> + let first = + let field = parseFieldDeclaration p in + Parser.expect Comma p; + {field with Parsetree.pld_attributes = attrs} + in + first + :: parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace ~f:parseFieldDeclarationRegion p in - let () = match fields with - | [] -> Parser.err ~startPos:lbrace p ( - Diagnostics.message "An inline record declaration needs at least one field" - ) - | _ -> () + let () = + match fields with + | [] -> + Parser.err ~startPos:lbrace p + (Diagnostics.message + "An inline record declaration needs at least one field") + | _ -> () in Parser.expect Rbrace p; Parser.optional p Comma |> ignore; Parser.expect Rparen p; - Parsetree.Pcstr_record fields - end - end + Parsetree.Pcstr_record fields)) | _ -> let args = - parseCommaDelimitedRegion - ~grammar:Grammar.TypExprList - ~closing:Rparen - ~f:parseTypExprRegion - p + parseCommaDelimitedRegion ~grammar:Grammar.TypExprList ~closing:Rparen + ~f:parseTypExprRegion p in Parser.expect Rparen p; - Parsetree.Pcstr_tuple args - end - | _ -> Pcstr_tuple [] + Parsetree.Pcstr_tuple args) + | _ -> Pcstr_tuple [] in - let res = match p.Parser.token with - | Colon -> - Parser.next p; - Some (parseTypExpr p) - | _ -> None + let res = + match p.Parser.token with + | Colon -> + Parser.next p; + Some (parseTypExpr p) + | _ -> None in (constrArgs, res) @@ -4525,7 +4638,7 @@ and parseConstrDeclArgs p = * | attrs constr-name * | constr-name const-args * | attrs constr-name const-args *) - and parseTypeConstructorDeclarationWithBar p = +and parseTypeConstructorDeclarationWithBar p = match p.Parser.token with | Bar -> let startPos = p.Parser.startPos in @@ -4533,37 +4646,35 @@ and parseConstrDeclArgs p = Some (parseTypeConstructorDeclaration ~startPos p) | _ -> None - and parseTypeConstructorDeclaration ~startPos p = - Parser.leaveBreadcrumb p Grammar.ConstructorDeclaration; - let attrs = parseAttributes p in - match p.Parser.token with - | Uident uident -> - let uidentLoc = mkLoc p.startPos p.endPos in - Parser.next p; - let (args, res) = parseConstrDeclArgs p in - Parser.eatBreadcrumb p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Type.constructor ~loc ~attrs ?res ~args (Location.mkloc uident uidentLoc) - | t -> +and parseTypeConstructorDeclaration ~startPos p = + Parser.leaveBreadcrumb p Grammar.ConstructorDeclaration; + let attrs = parseAttributes p in + match p.Parser.token with + | Uident uident -> + let uidentLoc = mkLoc p.startPos p.endPos in + Parser.next p; + let args, res = parseConstrDeclArgs p in + Parser.eatBreadcrumb p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Type.constructor ~loc ~attrs ?res ~args + (Location.mkloc uident uidentLoc) + | t -> Parser.err p (Diagnostics.uident t); Ast_helper.Type.constructor (Location.mknoloc "_") - (* [|] constr-decl { | constr-decl } *) - and parseTypeConstructorDeclarations ?first p = - let firstConstrDecl = match first with - | None -> - let startPos = p.Parser.startPos in - ignore (Parser.optional p Token.Bar); - parseTypeConstructorDeclaration ~startPos p - | Some firstConstrDecl -> - firstConstrDecl - in - firstConstrDecl::( - parseRegion - ~grammar:Grammar.ConstructorDeclaration - ~f:parseTypeConstructorDeclarationWithBar - p - ) +(* [|] constr-decl { | constr-decl } *) +and parseTypeConstructorDeclarations ?first p = + let firstConstrDecl = + match first with + | None -> + let startPos = p.Parser.startPos in + ignore (Parser.optional p Token.Bar); + parseTypeConstructorDeclaration ~startPos p + | Some firstConstrDecl -> firstConstrDecl + in + firstConstrDecl + :: parseRegion ~grammar:Grammar.ConstructorDeclaration + ~f:parseTypeConstructorDeclarationWithBar p (* * type-representation ::= @@ -4579,22 +4690,21 @@ and parseTypeRepresentation p = Parser.leaveBreadcrumb p Grammar.TypeRepresentation; (* = consumed *) let privateFlag = - if Parser.optional p Token.Private - then Asttypes.Private + if Parser.optional p Token.Private then Asttypes.Private else Asttypes.Public in - let kind = match p.Parser.token with - | Bar | Uident _ -> - Parsetree.Ptype_variant (parseTypeConstructorDeclarations p) - | Lbrace -> - Parsetree.Ptype_record (parseRecordDeclaration p) - | DotDot -> - Parser.next p; - Ptype_open - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - (* TODO: I have no idea if this is even remotely a good idea *) - Parsetree.Ptype_variant [] + let kind = + match p.Parser.token with + | Bar | Uident _ -> + Parsetree.Ptype_variant (parseTypeConstructorDeclarations p) + | Lbrace -> Parsetree.Ptype_record (parseRecordDeclaration p) + | DotDot -> + Parser.next p; + Ptype_open + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + (* TODO: I have no idea if this is even remotely a good idea *) + Parsetree.Ptype_variant [] in Parser.eatBreadcrumb p; (privateFlag, kind) @@ -4610,30 +4720,36 @@ and parseTypeRepresentation p = * | (* empty *) *) and parseTypeParam p = - let variance = match p.Parser.token with - | Plus -> Parser.next p; Asttypes.Covariant - | Minus -> Parser.next p; Contravariant - | _ -> Invariant + let variance = + match p.Parser.token with + | Plus -> + Parser.next p; + Asttypes.Covariant + | Minus -> + Parser.next p; + Contravariant + | _ -> Invariant in match p.Parser.token with | SingleQuote -> Parser.next p; - let (ident, loc) = - parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p in + let ident, loc = + parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p + in Some (Ast_helper.Typ.var ~loc ident, variance) | Underscore -> let loc = mkLoc p.startPos p.endPos in Parser.next p; Some (Ast_helper.Typ.any ~loc (), variance) | (Uident _ | Lident _) as token -> - Parser.err p (Diagnostics.message ( - "Type params start with a singlequote: '" ^ (Token.toString token) - )); - let (ident, loc) = - parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p in + Parser.err p + (Diagnostics.message + ("Type params start with a singlequote: '" ^ Token.toString token)); + let ident, loc = + parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p + in Some (Ast_helper.Typ.var ~loc ident, variance) - | _token -> - None + | _token -> None (* type-params ::= * | @@ -4646,40 +4762,39 @@ and parseTypeParam p = and parseTypeParams ~parent p = let opening = p.Parser.token in match opening with - | LessThan | Lparen when p.startPos.pos_lnum == p.prevEndPos.pos_lnum -> + | (LessThan | Lparen) when p.startPos.pos_lnum == p.prevEndPos.pos_lnum -> Scanner.setDiamondMode p.scanner; let openingStartPos = p.startPos in Parser.leaveBreadcrumb p Grammar.TypeParams; Parser.next p; let params = - parseCommaDelimitedRegion - ~grammar:Grammar.TypeParams - ~closing:GreaterThan - ~f:parseTypeParam - p + parseCommaDelimitedRegion ~grammar:Grammar.TypeParams ~closing:GreaterThan + ~f:parseTypeParam p in - let () = match p.token with - | Rparen when opening = Token.Lparen -> - let msg = - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.text "Type parameters require angle brackets:"; - Doc.indent ( - Doc.concat [ - Doc.line; - Doc.concat [ - ResPrinter.printLongident parent.Location.txt; - ResPrinter.printTypeParams params CommentTable.empty; - ] - ] - ) - ] - ) |> Doc.toString ~width:80 - in - Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); - Parser.next p - | _ -> - Parser.expect GreaterThan p + let () = + match p.token with + | Rparen when opening = Token.Lparen -> + let msg = + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "Type parameters require angle brackets:"; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.concat + [ + ResPrinter.printLongident parent.Location.txt; + ResPrinter.printTypeParams params CommentTable.empty; + ]; + ]); + ]) + |> Doc.toString ~width:80 + in + Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); + Parser.next p + | _ -> Parser.expect GreaterThan p in Scanner.popMode p.scanner Diamond; Parser.eatBreadcrumb p; @@ -4690,10 +4805,10 @@ and parseTypeParams ~parent p = and parseTypeConstraint p = let startPos = p.Parser.startPos in match p.Parser.token with - | Token.Constraint -> + | Token.Constraint -> ( Parser.next p; Parser.expect SingleQuote p; - begin match p.Parser.token with + match p.Parser.token with | Lident ident -> let identLoc = mkLoc startPos p.endPos in Parser.next p; @@ -4704,8 +4819,7 @@ and parseTypeConstraint p = | t -> Parser.err p (Diagnostics.lident t); let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Typ.any (), parseTypExpr p, loc) - end + Some (Ast_helper.Typ.any (), parseTypExpr p, loc)) | _ -> None (* type-constraints ::= @@ -4715,53 +4829,54 @@ and parseTypeConstraint p = * | type-constraint type-constraint type-constraint (* 0 or more *) *) and parseTypeConstraints p = - parseRegion - ~grammar:Grammar.TypeConstraint - ~f:parseTypeConstraint - p + parseRegion ~grammar:Grammar.TypeConstraint ~f:parseTypeConstraint p and parseTypeEquationOrConstrDecl p = let uidentStartPos = p.Parser.startPos in match p.Parser.token with - | Uident uident -> + | Uident uident -> ( Parser.next p; - begin match p.Parser.token with - | Dot -> + match p.Parser.token with + | Dot -> ( Parser.next p; let typeConstr = parseValuePathTail p uidentStartPos (Longident.Lident uident) in let loc = mkLoc uidentStartPos p.prevEndPos in - let typ = parseTypeAlias p ( - Ast_helper.Typ.constr ~loc typeConstr (parseTypeConstructorArgs ~constrName:typeConstr p) - ) in - begin match p.token with + let typ = + parseTypeAlias p + (Ast_helper.Typ.constr ~loc typeConstr + (parseTypeConstructorArgs ~constrName:typeConstr p)) + in + match p.token with | Equal -> Parser.next p; - let (priv, kind) = parseTypeRepresentation p in + let priv, kind = parseTypeRepresentation p in (Some typ, priv, kind) | EqualGreater -> Parser.next p; let returnType = parseTypExpr ~alias:false p in let loc = mkLoc uidentStartPos p.prevEndPos in - let arrowType = Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType in + let arrowType = + Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType + in let typ = parseTypeAlias p arrowType in (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | _ -> (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - end + | _ -> (Some typ, Asttypes.Public, Parsetree.Ptype_abstract)) | _ -> let uidentEndPos = p.prevEndPos in - let (args, res) = parseConstrDeclArgs p in - let first = Some ( - let uidentLoc = mkLoc uidentStartPos uidentEndPos in - Ast_helper.Type.constructor - ~loc:(mkLoc uidentStartPos p.prevEndPos) - ?res - ~args - (Location.mkloc uident uidentLoc) - ) in - (None, Asttypes.Public, Parsetree.Ptype_variant (parseTypeConstructorDeclarations p ?first)) - end + let args, res = parseConstrDeclArgs p in + let first = + Some + (let uidentLoc = mkLoc uidentStartPos uidentEndPos in + Ast_helper.Type.constructor + ~loc:(mkLoc uidentStartPos p.prevEndPos) + ?res ~args + (Location.mkloc uident uidentLoc)) + in + ( None, + Asttypes.Public, + Parsetree.Ptype_variant (parseTypeConstructorDeclarations p ?first) )) | t -> Parser.err p (Diagnostics.uident t); (* TODO: is this a good idea? *) @@ -4772,17 +4887,19 @@ and parseRecordOrObjectDecl p = Parser.expect Lbrace p; match p.Parser.token with | DotDot | Dot -> - let closedFlag = match p.token with - | DotDot -> Parser.next p; Asttypes.Open - | Dot -> Parser.next p; Asttypes.Closed - | _ -> Asttypes.Closed + let closedFlag = + match p.token with + | DotDot -> + Parser.next p; + Asttypes.Open + | Dot -> + Parser.next p; + Asttypes.Closed + | _ -> Asttypes.Closed in let fields = - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p + parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parseStringFieldDeclaration p in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in @@ -4792,34 +4909,32 @@ and parseRecordOrObjectDecl p = in let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | DotDotDot -> + | DotDotDot -> let dotdotdotStart = p.startPos in let dotdotdotEnd = p.endPos in (* start of object type spreading, e.g. `type u = {...a, "u": int}` *) Parser.next p; let typ = parseTypExpr p in - let () = match p.token with - | Rbrace -> - (* {...x}, spread without extra fields *) - Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p - (Diagnostics.message ErrorMessages.sameTypeSpread); - Parser.next p; - | _ -> Parser.expect Comma p + let () = + match p.token with + | Rbrace -> + (* {...x}, spread without extra fields *) + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.sameTypeSpread); + Parser.next p + | _ -> Parser.expect Comma p in - let () = match p.token with - | Lident _ -> - Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p - (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) - | _ -> () + let () = + match p.token with + | Lident _ -> + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) + | _ -> () in let fields = - (Parsetree.Oinherit typ)::( - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p - ) + Parsetree.Oinherit typ + :: parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parseStringFieldDeclaration p in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in @@ -4828,108 +4943,100 @@ and parseRecordOrObjectDecl p = in let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | _ -> + | _ -> ( let attrs = parseAttributes p in - begin match p.Parser.token with - | String _ -> + match p.Parser.token with + | String _ -> let closedFlag = Asttypes.Closed in - let fields = match attrs with - | [] -> - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p - | attrs -> - let first = - Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; - let field = match parseStringFieldDeclaration p with - | Some field -> field - | None -> assert false - in - (* parse comma after first *) - let () = match p.Parser.token with - | Rbrace | Eof -> () - | Comma -> Parser.next p - | _ -> Parser.expect Comma p + let fields = + match attrs with + | [] -> + parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parseStringFieldDeclaration p + | attrs -> + let first = + Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; + let field = + match parseStringFieldDeclaration p with + | Some field -> field + | None -> assert false + in + (* parse comma after first *) + let () = + match p.Parser.token with + | Rbrace | Eof -> () + | Comma -> Parser.next p + | _ -> Parser.expect Comma p + in + Parser.eatBreadcrumb p; + match field with + | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct) + | Oinherit ct -> Oinherit ct in - Parser.eatBreadcrumb p; - begin match field with - | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct) - | Oinherit ct -> Oinherit ct - end - in - first::( - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p - ) - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + first + :: parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parseStringFieldDeclaration p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag + |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) | _ -> Parser.leaveBreadcrumb p Grammar.RecordDecl; - let fields = match attrs with - | [] -> - parseCommaDelimitedRegion - ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace - ~f:parseFieldDeclarationRegion - p - | attr::_ as attrs -> - let first = - let field = parseFieldDeclaration p in - Parser.optional p Comma |> ignore; - {field with - Parsetree.pld_attributes = attrs; - pld_loc = { - field.Parsetree.pld_loc with loc_start = - (attr |> fst).loc.loc_start + let fields = + match attrs with + | [] -> + parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace ~f:parseFieldDeclarationRegion p + | attr :: _ as attrs -> + let first = + let field = parseFieldDeclaration p in + Parser.optional p Comma |> ignore; + { + field with + Parsetree.pld_attributes = attrs; + pld_loc = + { + field.Parsetree.pld_loc with + loc_start = (attr |> fst).loc.loc_start; + }; } - } - in - first::( - parseCommaDelimitedRegion - ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace - ~f:parseFieldDeclarationRegion - p - ) + in + first + :: parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace ~f:parseFieldDeclarationRegion p in - let () = match fields with - | [] -> Parser.err ~startPos p ( - Diagnostics.message "A record needs at least one field" - ) - | _ -> () + let () = + match fields with + | [] -> + Parser.err ~startPos p + (Diagnostics.message "A record needs at least one field") + | _ -> () in Parser.expect Rbrace p; Parser.eatBreadcrumb p; - (None, Asttypes.Public, Parsetree.Ptype_record fields) - end + (None, Asttypes.Public, Parsetree.Ptype_record fields)) and parsePrivateEqOrRepr p = Parser.expect Private p; match p.Parser.token with | Lbrace -> - let (manifest, _ ,kind) = parseRecordOrObjectDecl p in + let manifest, _, kind = parseRecordOrObjectDecl p in (manifest, Asttypes.Private, kind) | Uident _ -> - let (manifest, _, kind) = parseTypeEquationOrConstrDecl p in + let manifest, _, kind = parseTypeEquationOrConstrDecl p in (manifest, Asttypes.Private, kind) | Bar | DotDot -> - let (_, kind) = parseTypeRepresentation p in + let _, kind = parseTypeRepresentation p in (None, Asttypes.Private, kind) | t when Grammar.isTypExprStart t -> (Some (parseTypExpr p), Asttypes.Private, Parsetree.Ptype_abstract) | _ -> - let (_, kind) = parseTypeRepresentation p in + let _, kind = parseTypeRepresentation p in (None, Asttypes.Private, kind) (* @@ -4954,19 +5061,17 @@ and parsePolymorphicVariantType ~attrs p = | GreaterThan -> Parser.next p; let rowFields = - begin match p.token with - | Rbracket -> - [] - | Bar -> - parseTagSpecs p + match p.token with + | Rbracket -> [] + | Bar -> parseTagSpecs p | _ -> let rowField = parseTagSpec p in rowField :: parseTagSpecs p - end in let variant = let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc rowFields Open None in + Ast_helper.Typ.variant ~attrs ~loc rowFields Open None + in Parser.expect Rbracket p; variant | LessThan -> @@ -4977,7 +5082,9 @@ and parsePolymorphicVariantType ~attrs p = let tagNames = parseTagNames p in let variant = let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc (rowField :: rowFields) Closed (Some tagNames) in + Ast_helper.Typ.variant ~attrs ~loc (rowField :: rowFields) Closed + (Some tagNames) + in Parser.expect Rbracket p; variant | _ -> @@ -4985,42 +5092,38 @@ and parsePolymorphicVariantType ~attrs p = let rowFields2 = parseTagSpecs p in let variant = let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc (rowFields1 @ rowFields2) Closed None in + Ast_helper.Typ.variant ~attrs ~loc (rowFields1 @ rowFields2) Closed None + in Parser.expect Rbracket p; variant and parseTagName p = match p.Parser.token with | Hash -> - let (ident, _loc) = parseHashIdent ~startPos:p.startPos p in + let ident, _loc = parseHashIdent ~startPos:p.startPos p in Some ident | _ -> None and parseTagNames p = - if p.Parser.token == GreaterThan then - (Parser.next p; + if p.Parser.token == GreaterThan then ( + Parser.next p; parseRegion p ~grammar:Grammar.TagNames ~f:parseTagName) - else - [] + else [] and parseTagSpecFulls p = match p.Parser.token with - | Rbracket -> - [] - | GreaterThan -> - [] + | Rbracket -> [] + | GreaterThan -> [] | Bar -> Parser.next p; let rowField = parseTagSpecFull p in - rowField ::parseTagSpecFulls p - | _ -> - [] + rowField :: parseTagSpecFulls p + | _ -> [] and parseTagSpecFull p = let attrs = parseAttributes p in match p.Parser.token with - | Hash -> - parsePolymorphicVariantTypeSpecHash ~attrs ~full:true p + | Hash -> parsePolymorphicVariantTypeSpecHash ~attrs ~full:true p | _ -> let typ = parseTypExpr ~attrs p in Parsetree.Rinherit typ @@ -5031,14 +5134,12 @@ and parseTagSpecs p = Parser.next p; let rowField = parseTagSpec p in rowField :: parseTagSpecs p - | _ -> - [] + | _ -> [] and parseTagSpec p = let attrs = parseAttributes p in match p.Parser.token with - | Hash -> - parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p + | Hash -> parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p | _ -> let typ = parseTypExpr ~attrs p in Parsetree.Rinherit typ @@ -5049,96 +5150,80 @@ and parseTagSpecFirst p = | Bar -> Parser.next p; [parseTagSpec p] - | Hash -> - [parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p] - | _ -> + | Hash -> [parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p] + | _ -> ( let typ = parseTypExpr ~attrs p in - begin match p.token with + match p.token with | Rbracket -> (* example: [ListStyleType.t] *) - [Parsetree.Rinherit typ;] + [Parsetree.Rinherit typ] | _ -> Parser.expect Bar p; - [Parsetree.Rinherit typ; parseTagSpec p] - end + [Parsetree.Rinherit typ; parseTagSpec p]) and parsePolymorphicVariantTypeSpecHash ~attrs ~full p : Parsetree.row_field = let startPos = p.Parser.startPos in - let (ident, loc) = parseHashIdent ~startPos p in + let ident, loc = parseHashIdent ~startPos p in let rec loop p = match p.Parser.token with | Band when full -> Parser.next p; let rowField = parsePolymorphicVariantTypeArgs p in rowField :: loop p - | _ -> - [] + | _ -> [] in let firstTuple, tagContainsAConstantEmptyConstructor = match p.Parser.token with | Band when full -> Parser.next p; - [parsePolymorphicVariantTypeArgs p], true - | Lparen -> - [parsePolymorphicVariantTypeArgs p], false - | _ -> - [], true + ([parsePolymorphicVariantTypeArgs p], true) + | Lparen -> ([parsePolymorphicVariantTypeArgs p], false) + | _ -> ([], true) in let tuples = firstTuple @ loop p in - Parsetree.Rtag ( - Location.mkloc ident loc, - attrs, - tagContainsAConstantEmptyConstructor, - tuples - ) + Parsetree.Rtag + ( Location.mkloc ident loc, + attrs, + tagContainsAConstantEmptyConstructor, + tuples ) and parsePolymorphicVariantTypeArgs p = let startPos = p.Parser.startPos in Parser.expect Lparen p; - let args = parseCommaDelimitedRegion - ~grammar:Grammar.TypExprList - ~closing:Rparen - ~f:parseTypExprRegion - p + let args = + parseCommaDelimitedRegion ~grammar:Grammar.TypExprList ~closing:Rparen + ~f:parseTypExprRegion p in Parser.expect Rparen p; let attrs = [] in let loc = mkLoc startPos p.prevEndPos in match args with - | [{ptyp_desc = Ptyp_tuple _} as typ] as types -> - if p.mode = ParseForTypeChecker then - typ - else - Ast_helper.Typ.tuple ~loc ~attrs types + | [({ptyp_desc = Ptyp_tuple _} as typ)] as types -> + if p.mode = ParseForTypeChecker then typ + else Ast_helper.Typ.tuple ~loc ~attrs types | [typ] -> typ | types -> Ast_helper.Typ.tuple ~loc ~attrs types and parseTypeEquationAndRepresentation p = match p.Parser.token with - | Equal | Bar as token -> + | (Equal | Bar) as token -> ( if token = Bar then Parser.expect Equal p; Parser.next p; - begin match p.Parser.token with - | Uident _ -> - parseTypeEquationOrConstrDecl p - | Lbrace -> - parseRecordOrObjectDecl p - | Private -> - parsePrivateEqOrRepr p + match p.Parser.token with + | Uident _ -> parseTypeEquationOrConstrDecl p + | Lbrace -> parseRecordOrObjectDecl p + | Private -> parsePrivateEqOrRepr p | Bar | DotDot -> - let (priv, kind) = parseTypeRepresentation p in + let priv, kind = parseTypeRepresentation p in (None, priv, kind) - | _ -> + | _ -> ( let manifest = Some (parseTypExpr p) in - begin match p.Parser.token with + match p.Parser.token with | Equal -> Parser.next p; - let (priv, kind) = parseTypeRepresentation p in + let priv, kind = parseTypeRepresentation p in (manifest, priv, kind) - | _ -> - (manifest, Public, Parsetree.Ptype_abstract) - end - end + | _ -> (manifest, Public, Parsetree.Ptype_abstract))) | _ -> (None, Public, Parsetree.Ptype_abstract) (* type-definition ::= type [rec] typedef { and typedef } @@ -5149,18 +5234,19 @@ and parseTypeDef ~attrs ~startPos p = Parser.leaveBreadcrumb p Grammar.TypeDef; (* let attrs = match attrs with | Some attrs -> attrs | None -> parseAttributes p in *) Parser.leaveBreadcrumb p Grammar.TypeConstrName; - let (name, loc) = parseLident p in + let name, loc = parseLident p in let typeConstrName = Location.mkloc name loc in Parser.eatBreadcrumb p; let params = let constrName = Location.mkloc (Longident.Lident name) loc in - parseTypeParams ~parent:constrName p in + parseTypeParams ~parent:constrName p + in let typeDef = - let (manifest, priv, kind) = parseTypeEquationAndRepresentation p in + let manifest, priv, kind = parseTypeEquationAndRepresentation p in let cstrs = parseTypeConstraints p in let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Type.mk - ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest typeConstrName + Ast_helper.Type.mk ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest + typeConstrName in Parser.eatBreadcrumb p; typeDef @@ -5168,19 +5254,18 @@ and parseTypeDef ~attrs ~startPos p = and parseTypeExtension ~params ~attrs ~name p = Parser.expect PlusEqual p; let priv = - if Parser.optional p Token.Private - then Asttypes.Private + if Parser.optional p Token.Private then Asttypes.Private else Asttypes.Public in let constrStart = p.Parser.startPos in Parser.optional p Bar |> ignore; let first = - let (attrs, name, kind) = match p.Parser.token with - | Bar -> - Parser.next p; - parseConstrDef ~parseAttrs:true p - | _ -> - parseConstrDef ~parseAttrs:true p + let attrs, name, kind = + match p.Parser.token with + | Bar -> + Parser.next p; + parseConstrDef ~parseAttrs:true p + | _ -> parseConstrDef ~parseAttrs:true p in let loc = mkLoc constrStart p.prevEndPos in Ast_helper.Te.constructor ~loc ~attrs name kind @@ -5190,46 +5275,48 @@ and parseTypeExtension ~params ~attrs ~name p = | Bar -> let startPos = p.Parser.startPos in Parser.next p; - let (attrs, name, kind) = parseConstrDef ~parseAttrs:true p in + let attrs, name, kind = parseConstrDef ~parseAttrs:true p in let extConstr = - Ast_helper.Te.constructor ~attrs ~loc:(mkLoc startPos p.prevEndPos) name kind + Ast_helper.Te.constructor ~attrs + ~loc:(mkLoc startPos p.prevEndPos) + name kind in - loop p (extConstr::cs) - | _ -> - List.rev cs + loop p (extConstr :: cs) + | _ -> List.rev cs in let constructors = loop p [first] in Ast_helper.Te.mk ~attrs ~params ~priv name constructors and parseTypeDefinitions ~attrs ~name ~params ~startPos p = - let typeDef = - let (manifest, priv, kind) = parseTypeEquationAndRepresentation p in - let cstrs = parseTypeConstraints p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Type.mk - ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest - {name with txt = lidentOfPath name.Location.txt} - in - let rec loop p defs = - let startPos = p.Parser.startPos in - let attrs = parseAttributesAndBinding p in - match p.Parser.token with - | And -> - Parser.next p; - let attrs = match p.token with + let typeDef = + let manifest, priv, kind = parseTypeEquationAndRepresentation p in + let cstrs = parseTypeConstraints p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Type.mk ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest + {name with txt = lidentOfPath name.Location.txt} + in + let rec loop p defs = + let startPos = p.Parser.startPos in + let attrs = parseAttributesAndBinding p in + match p.Parser.token with + | And -> + Parser.next p; + let attrs = + match p.token with | Export -> let exportLoc = mkLoc p.startPos p.endPos in Parser.next p; - let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in - genTypeAttr::attrs + let genTypeAttr = + (Location.mkloc "genType" exportLoc, Parsetree.PStr []) + in + genTypeAttr :: attrs | _ -> attrs - in - let typeDef = parseTypeDef ~attrs ~startPos p in - loop p (typeDef::defs) - | _ -> - List.rev defs - in - loop p [typeDef] + in + let typeDef = parseTypeDef ~attrs ~startPos p in + loop p (typeDef :: defs) + | _ -> List.rev defs + in + loop p [typeDef] (* TODO: decide if we really want type extensions (eg. type x += Blue) * It adds quite a bit of complexity that can be avoided, @@ -5238,8 +5325,11 @@ and parseTypeDefinitions ~attrs ~name ~params ~startPos p = and parseTypeDefinitionOrExtension ~attrs p = let startPos = p.Parser.startPos in Parser.expect Token.Typ p; - let recFlag = match p.token with - | Rec -> Parser.next p; Asttypes.Recursive + let recFlag = + match p.token with + | Rec -> + Parser.next p; + Asttypes.Recursive | Lident "nonrec" -> Parser.next p; Asttypes.Nonrecursive @@ -5248,15 +5338,16 @@ and parseTypeDefinitionOrExtension ~attrs p = let name = parseValuePath p in let params = parseTypeParams ~parent:name p in match p.Parser.token with - | PlusEqual -> - TypeExt(parseTypeExtension ~params ~attrs ~name p) + | PlusEqual -> TypeExt (parseTypeExtension ~params ~attrs ~name p) | _ -> (* shape of type name should be Lident, i.e. `t` is accepted. `User.t` not *) - let () = match name.Location.txt with - | Lident _ -> () - | longident -> - Parser.err ~startPos:name.loc.loc_start ~endPos:name.loc.loc_end p - (longident |> ErrorMessages.typeDeclarationNameLongident |> Diagnostics.message) + let () = + match name.Location.txt with + | Lident _ -> () + | longident -> + Parser.err ~startPos:name.loc.loc_start ~endPos:name.loc.loc_end p + (longident |> ErrorMessages.typeDeclarationNameLongident + |> Diagnostics.message) in let typeDefs = parseTypeDefinitions ~attrs ~name ~params ~startPos p in TypeDef {recFlag; types = typeDefs} @@ -5265,21 +5356,24 @@ and parseTypeDefinitionOrExtension ~attrs p = and parseExternalDef ~attrs ~startPos p = Parser.leaveBreadcrumb p Grammar.External; Parser.expect Token.External p; - let (name, loc) = parseLident p in + let name, loc = parseLident p in let name = Location.mkloc name loc in - Parser.expect ~grammar:(Grammar.TypeExpression) Colon p; + Parser.expect ~grammar:Grammar.TypeExpression Colon p; let typExpr = parseTypExpr p in let equalStart = p.startPos in let equalEnd = p.endPos in Parser.expect Equal p; - let prim = match p.token with - | String s -> Parser.next p; [s] - | _ -> + let prim = + match p.token with + | String s -> + Parser.next p; + [s] + | _ -> Parser.err ~startPos:equalStart ~endPos:equalEnd p (Diagnostics.message - ("An external requires the name of the JS value you're referring to, like \"" - ^ name.txt ^ "\".")); - [] + ("An external requires the name of the JS value you're referring \ + to, like \"" ^ name.txt ^ "\".")); + [] in let loc = mkLoc startPos p.prevEndPos in let vb = Ast_helper.Val.mk ~loc ~attrs ~prim name typExpr in @@ -5295,29 +5389,30 @@ and parseExternalDef ~attrs ~startPos p = * constr ::= path-uident *) and parseConstrDef ~parseAttrs p = let attrs = if parseAttrs then parseAttributes p else [] in - let name = match p.Parser.token with - | Uident name -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc name loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + let name = + match p.Parser.token with + | Uident name -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc name loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in - let kind = match p.Parser.token with - | Lparen -> - let (args, res) = parseConstrDeclArgs p in - Parsetree.Pext_decl (args, res) - | Equal -> - Parser.next p; - let longident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pext_rebind longident - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - Parsetree.Pext_decl (Pcstr_tuple [], Some typ) - | _ -> - Parsetree.Pext_decl (Pcstr_tuple [], None) + let kind = + match p.Parser.token with + | Lparen -> + let args, res = parseConstrDeclArgs p in + Parsetree.Pext_decl (args, res) + | Equal -> + Parser.next p; + let longident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pext_rebind longident + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + Parsetree.Pext_decl (Pcstr_tuple [], Some typ) + | _ -> Parsetree.Pext_decl (Pcstr_tuple [], None) in (attrs, name, kind) @@ -5331,22 +5426,20 @@ and parseConstrDef ~parseAttrs p = and parseExceptionDef ~attrs p = let startPos = p.Parser.startPos in Parser.expect Token.Exception p; - let (_, name, kind) = parseConstrDef ~parseAttrs:false p in + let _, name, kind = parseConstrDef ~parseAttrs:false p in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Te.constructor ~loc ~attrs name kind and parseNewlineOrSemicolonStructure p = match p.Parser.token with - | Semicolon -> - Parser.next p + | Semicolon -> Parser.next p | token when Grammar.isStructureItemStart token -> if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () else - Parser.err - ~startPos:p.prevEndPos - ~endPos: p.endPos - p - (Diagnostics.message "consecutive statements on a line must be separated by ';' or a newline") + Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p + (Diagnostics.message + "consecutive statements on a line must be separated by ';' or a \ + newline") | _ -> () and parseStructureItemRegion p = @@ -5359,24 +5452,23 @@ and parseStructureItemRegion p = let loc = mkLoc startPos p.prevEndPos in Some (Ast_helper.Str.open_ ~loc openDescription) | Let -> - let (recFlag, letBindings) = parseLetBindings ~attrs p in + let recFlag, letBindings = parseLetBindings ~attrs p in parseNewlineOrSemicolonStructure p; let loc = mkLoc startPos p.prevEndPos in Some (Ast_helper.Str.value ~loc recFlag letBindings) - | Typ -> + | Typ -> ( Parser.beginRegion p; - begin match parseTypeDefinitionOrExtension ~attrs p with + match parseTypeDefinitionOrExtension ~attrs p with | TypeDef {recFlag; types} -> parseNewlineOrSemicolonStructure p; let loc = mkLoc startPos p.prevEndPos in Parser.endRegion p; Some (Ast_helper.Str.type_ ~loc recFlag types) - | TypeExt(ext) -> + | TypeExt ext -> parseNewlineOrSemicolonStructure p; let loc = mkLoc startPos p.prevEndPos in Parser.endRegion p; - Some (Ast_helper.Str.type_extension ~loc ext) - end + Some (Ast_helper.Str.type_extension ~loc ext)) | External -> let externalDef = parseExternalDef ~attrs ~startPos p in parseNewlineOrSemicolonStructure p; @@ -5425,32 +5517,32 @@ and parseStructureItemRegion p = let exp = parseExpr p in parseNewlineOrSemicolonStructure p; let loc = mkLoc startPos p.prevEndPos in - Parser.checkProgress ~prevEndPos ~result:(Ast_helper.Str.eval ~loc ~attrs exp) p - | _ -> - begin match attrs with - | (({Asttypes.loc = attrLoc}, _) as attr)::_ -> - Parser.err - ~startPos:attrLoc.loc_start - ~endPos:attrLoc.loc_end - p - (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); + Parser.checkProgress ~prevEndPos + ~result:(Ast_helper.Str.eval ~loc ~attrs exp) + p + | _ -> ( + match attrs with + | (({Asttypes.loc = attrLoc}, _) as attr) :: _ -> + Parser.err ~startPos:attrLoc.loc_start ~endPos:attrLoc.loc_end p + (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); let expr = parseExpr p in - Some (Ast_helper.Str.eval ~loc:(mkLoc p.startPos p.prevEndPos) ~attrs expr) - | _ -> - None - end - [@@progress (Parser.next, Parser.expect)] + Some + (Ast_helper.Str.eval ~loc:(mkLoc p.startPos p.prevEndPos) ~attrs expr) + | _ -> None) + [@@progress Parser.next, Parser.expect] and parseJsImport ~startPos ~attrs p = Parser.expect Token.Import p; - let importSpec = match p.Parser.token with - | Token.Lident _ | Token.At -> - let decl = match parseJsFfiDeclaration p with - | Some decl -> decl - | None -> assert false - in - JsFfi.Default decl - | _ -> JsFfi.Spec(parseJsFfiDeclarations p) + let importSpec = + match p.Parser.token with + | Token.Lident _ | Token.At -> + let decl = + match parseJsFfiDeclaration p with + | Some decl -> decl + | None -> assert false + in + JsFfi.Default decl + | _ -> JsFfi.Spec (parseJsFfiDeclarations p) in let scope = parseJsFfiScope p in let loc = mkLoc startPos p.prevEndPos in @@ -5461,17 +5553,15 @@ and parseJsExport ~attrs p = Parser.expect Token.Export p; let exportLoc = mkLoc exportStart p.prevEndPos in let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in - let attrs = genTypeAttr::attrs in + let attrs = genTypeAttr :: attrs in match p.Parser.token with - | Typ -> - begin match parseTypeDefinitionOrExtension ~attrs p with - | TypeDef {recFlag; types} -> - Ast_helper.Str.type_ recFlag types - | TypeExt(ext) -> - Ast_helper.Str.type_extension ext - end - | (* Let *) _ -> - let (recFlag, letBindings) = parseLetBindings ~attrs p in + | Typ -> ( + match parseTypeDefinitionOrExtension ~attrs p with + | TypeDef {recFlag; types} -> Ast_helper.Str.type_ recFlag types + | TypeExt ext -> Ast_helper.Str.type_extension ext) + (* Let *) + | _ -> + let recFlag, letBindings = parseLetBindings ~attrs p in Ast_helper.Str.value recFlag letBindings and parseSignJsExport ~attrs p = @@ -5479,42 +5569,41 @@ and parseSignJsExport ~attrs p = Parser.expect Token.Export p; let exportLoc = mkLoc exportStart p.prevEndPos in let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in - let attrs = genTypeAttr::attrs in + let attrs = genTypeAttr :: attrs in match p.Parser.token with - | Typ -> - begin match parseTypeDefinitionOrExtension ~attrs p with + | Typ -> ( + match parseTypeDefinitionOrExtension ~attrs p with | TypeDef {recFlag; types} -> let loc = mkLoc exportStart p.prevEndPos in Ast_helper.Sig.type_ recFlag types ~loc - | TypeExt(ext) -> + | TypeExt ext -> let loc = mkLoc exportStart p.prevEndPos in - Ast_helper.Sig.type_extension ext ~loc - end - | (* Let *) _ -> + Ast_helper.Sig.type_extension ext ~loc) + (* Let *) + | _ -> let valueDesc = parseSignLetDesc ~attrs p in let loc = mkLoc exportStart p.prevEndPos in Ast_helper.Sig.value valueDesc ~loc and parseJsFfiScope p = match p.Parser.token with - | Token.Lident "from" -> + | Token.Lident "from" -> ( Parser.next p; - begin match p.token with - | String s -> Parser.next p; JsFfi.Module s + match p.token with + | String s -> + Parser.next p; + JsFfi.Module s | Uident _ | Lident _ -> let value = parseIdentPath p in JsFfi.Scope value - | _ -> JsFfi.Global - end + | _ -> JsFfi.Global) | _ -> JsFfi.Global and parseJsFfiDeclarations p = Parser.expect Token.Lbrace p; - let decls = parseCommaDelimitedRegion - ~grammar:Grammar.JsFfiImport - ~closing:Rbrace - ~f:parseJsFfiDeclaration - p + let decls = + parseCommaDelimitedRegion ~grammar:Grammar.JsFfiImport ~closing:Rbrace + ~f:parseJsFfiDeclaration p in Parser.expect Rbrace p; decls @@ -5524,14 +5613,14 @@ and parseJsFfiDeclaration p = let attrs = parseAttributes p in match p.Parser.token with | Lident _ -> - let (ident, _) = parseLident p in - let alias = match p.token with - | As -> - Parser.next p; - let (ident, _) = parseLident p in - ident - | _ -> - ident + let ident, _ = parseLident p in + let alias = + match p.token with + | As -> + Parser.next p; + let ident, _ = parseLident p in + ident + | _ -> ident in Parser.expect Token.Colon p; let typ = parseTypExpr p in @@ -5555,31 +5644,29 @@ and parseAtomicModuleExpr p = Ast_helper.Mod.ident ~loc:longident.loc longident | Lbrace -> Parser.next p; - let structure = Ast_helper.Mod.structure ( - parseDelimitedRegion - ~grammar:Grammar.Structure - ~closing:Rbrace - ~f:parseStructureItemRegion - p - ) in + let structure = + Ast_helper.Mod.structure + (parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rbrace + ~f:parseStructureItemRegion p) + in Parser.expect Rbrace p; let endPos = p.prevEndPos in {structure with pmod_loc = mkLoc startPos endPos} | Lparen -> Parser.next p; - let modExpr = match p.token with - | Rparen -> - Ast_helper.Mod.structure ~loc:(mkLoc startPos p.prevEndPos) [] - | _ -> - parseConstrainedModExpr p + let modExpr = + match p.token with + | Rparen -> Ast_helper.Mod.structure ~loc:(mkLoc startPos p.prevEndPos) [] + | _ -> parseConstrainedModExpr p in Parser.expect Rparen p; modExpr - | Lident "unpack" -> (* TODO: should this be made a keyword?? *) + | Lident "unpack" -> ( + (* TODO: should this be made a keyword?? *) Parser.next p; Parser.expect Lparen p; let expr = parseExpr p in - begin match p.Parser.token with + match p.Parser.token with | Colon -> let colonStart = p.Parser.startPos in Parser.next p; @@ -5587,23 +5674,19 @@ and parseAtomicModuleExpr p = let packageType = parsePackageType ~startPos:colonStart ~attrs p in Parser.expect Rparen p; let loc = mkLoc startPos p.prevEndPos in - let constraintExpr = Ast_helper.Exp.constraint_ - ~loc - expr packageType - in + let constraintExpr = Ast_helper.Exp.constraint_ ~loc expr packageType in Ast_helper.Mod.unpack ~loc constraintExpr | _ -> Parser.expect Rparen p; let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mod.unpack ~loc expr - end + Ast_helper.Mod.unpack ~loc expr) | Percent -> let extension = parseExtension p in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Mod.extension ~loc extension | token -> Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleExpr() + Recover.defaultModuleExpr () and parsePrimaryModExpr p = let startPos = p.Parser.startPos in @@ -5628,10 +5711,10 @@ and parseFunctorArg p = let startPos = p.Parser.startPos in let attrs = parseAttributes p in match p.Parser.token with - | Uident ident -> + | Uident ident -> ( Parser.next p; let uidentEndPos = p.prevEndPos in - begin match p.Parser.token with + match p.Parser.token with | Colon -> Parser.next p; let moduleType = parseModuleType p in @@ -5642,7 +5725,9 @@ and parseFunctorArg p = Parser.next p; let moduleType = let moduleLongIdent = - parseModuleLongIdentTail ~lowercase:false p startPos (Longident.Lident ident) in + parseModuleLongIdentTail ~lowercase:false p startPos + (Longident.Lident ident) + in Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent in let argName = Location.mknoloc "_" in @@ -5652,8 +5737,7 @@ and parseFunctorArg p = let modIdent = Location.mkloc (Longident.Lident ident) loc in let moduleType = Ast_helper.Mty.ident ~loc modIdent in let argName = Location.mknoloc "_" in - Some (attrs, argName, Some moduleType, startPos) - end + Some (attrs, argName, Some moduleType, startPos)) | Underscore -> Parser.next p; let argName = Location.mkloc "_" (mkLoc startPos p.prevEndPos) in @@ -5665,33 +5749,30 @@ and parseFunctorArg p = Parser.expect Rparen p; let argName = Location.mkloc "*" (mkLoc startPos p.prevEndPos) in Some (attrs, argName, None, startPos) - | _ -> - None + | _ -> None and parseFunctorArgs p = let startPos = p.Parser.startPos in Parser.expect Lparen p; let args = - parseCommaDelimitedRegion - ~grammar:Grammar.FunctorArgs - ~closing:Rparen - ~f:parseFunctorArg - p + parseCommaDelimitedRegion ~grammar:Grammar.FunctorArgs ~closing:Rparen + ~f:parseFunctorArg p in Parser.expect Rparen p; match args with | [] -> - [[], Location.mkloc "*" (mkLoc startPos p.prevEndPos), None, startPos] + [([], Location.mkloc "*" (mkLoc startPos p.prevEndPos), None, startPos)] | args -> args and parseFunctorModuleExpr p = let startPos = p.Parser.startPos in let args = parseFunctorArgs p in - let returnType = match p.Parser.token with - | Colon -> - Parser.next p; - Some (parseModuleType ~es6Arrow:false p) - | _ -> None + let returnType = + match p.Parser.token with + | Colon -> + Parser.next p; + Some (parseModuleType ~es6Arrow:false p) + | _ -> None in Parser.expect EqualGreater p; let rhsModuleExpr = @@ -5699,17 +5780,18 @@ and parseFunctorModuleExpr p = match returnType with | Some modType -> Ast_helper.Mod.constraint_ - ~loc:(mkLoc modExpr.pmod_loc.loc_start modType.Parsetree.pmty_loc.loc_end) + ~loc: + (mkLoc modExpr.pmod_loc.loc_start modType.Parsetree.pmty_loc.loc_end) modExpr modType | None -> modExpr in let endPos = p.prevEndPos in - let modExpr = List.fold_right (fun (attrs, name, moduleType, startPos) acc -> - Ast_helper.Mod.functor_ - ~loc:(mkLoc startPos endPos) - ~attrs - name moduleType acc - ) args rhsModuleExpr + let modExpr = + List.fold_right + (fun (attrs, name, moduleType, startPos) acc -> + Ast_helper.Mod.functor_ ~loc:(mkLoc startPos endPos) ~attrs name + moduleType acc) + args rhsModuleExpr in {modExpr with pmod_loc = mkLoc startPos endPos} @@ -5724,10 +5806,9 @@ and parseFunctorModuleExpr p = * | attributes module-expr *) and parseModuleExpr p = let attrs = parseAttributes p in - let modExpr = if isEs6ArrowFunctor p then - parseFunctorModuleExpr p - else - parsePrimaryModExpr p + let modExpr = + if isEs6ArrowFunctor p then parseFunctorModuleExpr p + else parsePrimaryModExpr p in {modExpr with pmod_attributes = List.concat [modExpr.pmod_attributes; attrs]} @@ -5742,33 +5823,32 @@ and parseConstrainedModExpr p = | _ -> modExpr and parseConstrainedModExprRegion p = - if Grammar.isModExprStart p.Parser.token then - Some (parseConstrainedModExpr p) - else - None + if Grammar.isModExprStart p.Parser.token then Some (parseConstrainedModExpr p) + else None and parseModuleApplication p modExpr = let startPos = p.Parser.startPos in Parser.expect Lparen p; let args = - parseCommaDelimitedRegion - ~grammar:Grammar.ModExprList - ~closing:Rparen - ~f:parseConstrainedModExprRegion - p + parseCommaDelimitedRegion ~grammar:Grammar.ModExprList ~closing:Rparen + ~f:parseConstrainedModExprRegion p in Parser.expect Rparen p; - let args = match args with - | [] -> - let loc = mkLoc startPos p.prevEndPos in - [Ast_helper.Mod.structure ~loc []] - | args -> args - in - List.fold_left (fun modExpr arg -> - Ast_helper.Mod.apply - ~loc:(mkLoc modExpr.Parsetree.pmod_loc.loc_start arg.Parsetree.pmod_loc.loc_end) - modExpr arg - ) modExpr args + let args = + match args with + | [] -> + let loc = mkLoc startPos p.prevEndPos in + [Ast_helper.Mod.structure ~loc []] + | args -> args + in + List.fold_left + (fun modExpr arg -> + Ast_helper.Mod.apply + ~loc: + (mkLoc modExpr.Parsetree.pmod_loc.loc_start + arg.Parsetree.pmod_loc.loc_end) + modExpr arg) + modExpr args and parseModuleOrModuleTypeImplOrPackExpr ~attrs p = let startPos = p.Parser.startPos in @@ -5786,52 +5866,53 @@ and parseModuleOrModuleTypeImplOrPackExpr ~attrs p = and parseModuleTypeImpl ~attrs startPos p = Parser.expect Typ p; let nameStart = p.Parser.startPos in - let name = match p.Parser.token with - | Lident ident -> - Parser.next p; - let loc = mkLoc nameStart p.prevEndPos in - Location.mkloc ident loc - | Uident ident -> - Parser.next p; - let loc = mkLoc nameStart p.prevEndPos in - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + let name = + match p.Parser.token with + | Lident ident -> + Parser.next p; + let loc = mkLoc nameStart p.prevEndPos in + Location.mkloc ident loc + | Uident ident -> + Parser.next p; + let loc = mkLoc nameStart p.prevEndPos in + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in Parser.expect Equal p; let moduleType = parseModuleType p in let moduleTypeDeclaration = - Ast_helper.Mtd.mk - ~attrs + Ast_helper.Mtd.mk ~attrs ~loc:(mkLoc nameStart p.prevEndPos) - ~typ:moduleType - name + ~typ:moduleType name in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Str.modtype ~loc moduleTypeDeclaration (* definition ::= - ∣ module rec module-name : module-type = module-expr { and module-name - : module-type = module-expr } *) + ∣ module rec module-name : module-type = module-expr { and module-name + : module-type = module-expr } *) and parseMaybeRecModuleBinding ~attrs ~startPos p = match p.Parser.token with | Token.Rec -> Parser.next p; Ast_helper.Str.rec_module (parseModuleBindings ~startPos ~attrs p) | _ -> - Ast_helper.Str.module_ (parseModuleBinding ~attrs ~startPos:p.Parser.startPos p) + Ast_helper.Str.module_ + (parseModuleBinding ~attrs ~startPos:p.Parser.startPos p) and parseModuleBinding ~attrs ~startPos p = - let name = match p.Parser.token with - | Uident ident -> - let startPos = p.Parser.startPos in - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + let name = + match p.Parser.token with + | Uident ident -> + let startPos = p.Parser.startPos in + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in let body = parseModuleBindingBody p in let loc = mkLoc startPos p.prevEndPos in @@ -5839,11 +5920,12 @@ and parseModuleBinding ~attrs ~startPos p = and parseModuleBindingBody p = (* TODO: make required with good error message when rec module binding *) - let returnModType = match p.Parser.token with - | Colon -> - Parser.next p; - Some (parseModuleType p) - | _ -> None + let returnModType = + match p.Parser.token with + | Colon -> + Parser.next p; + Some (parseModuleType p) + | _ -> None in Parser.expect Equal p; let modExpr = parseModuleExpr p in @@ -5854,7 +5936,6 @@ and parseModuleBindingBody p = modExpr modType | None -> modExpr - (* module-name : module-type = module-expr * { and module-name : module-type = module-expr } *) and parseModuleBindings ~attrs ~startPos p = @@ -5864,9 +5945,10 @@ and parseModuleBindings ~attrs ~startPos p = match p.Parser.token with | And -> Parser.next p; - ignore(Parser.optional p Module); (* over-parse for fault-tolerance *) + ignore (Parser.optional p Module); + (* over-parse for fault-tolerance *) let modBinding = parseModuleBinding ~attrs ~startPos p in - loop p (modBinding::acc) + loop p (modBinding :: acc) | _ -> List.rev acc in let first = parseModuleBinding ~attrs ~startPos p in @@ -5874,38 +5956,37 @@ and parseModuleBindings ~attrs ~startPos p = and parseAtomicModuleType p = let startPos = p.Parser.startPos in - let moduleType = match p.Parser.token with - | Uident _ | Lident _ -> - (* Ocaml allows module types to end with lowercase: module Foo : bar = { ... } - * lets go with uppercase terminal for now *) - let moduleLongIdent = parseModuleLongIdent ~lowercase:true p in - Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent - | Lparen -> - Parser.next p; - let mty = parseModuleType p in - Parser.expect Rparen p; - {mty with pmty_loc = mkLoc startPos p.prevEndPos} - | Lbrace -> - Parser.next p; - let spec = - parseDelimitedRegion - ~grammar:Grammar.Signature - ~closing:Rbrace - ~f:parseSignatureItemRegion - p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mty.signature ~loc spec - | Module -> (* TODO: check if this is still atomic when implementing first class modules*) - parseModuleTypeOf p - | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mty.extension ~loc extension - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleType() + let moduleType = + match p.Parser.token with + | Uident _ | Lident _ -> + (* Ocaml allows module types to end with lowercase: module Foo : bar = { ... } + * lets go with uppercase terminal for now *) + let moduleLongIdent = parseModuleLongIdent ~lowercase:true p in + Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent + | Lparen -> + Parser.next p; + let mty = parseModuleType p in + Parser.expect Rparen p; + {mty with pmty_loc = mkLoc startPos p.prevEndPos} + | Lbrace -> + Parser.next p; + let spec = + parseDelimitedRegion ~grammar:Grammar.Signature ~closing:Rbrace + ~f:parseSignatureItemRegion p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mty.signature ~loc spec + | Module -> + (* TODO: check if this is still atomic when implementing first class modules*) + parseModuleTypeOf p + | Percent -> + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mty.extension ~loc extension + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultModuleType () in let moduleTypeLoc = mkLoc startPos p.prevEndPos in {moduleType with pmty_loc = moduleTypeLoc} @@ -5916,12 +5997,12 @@ and parseFunctorModuleType p = Parser.expect EqualGreater p; let rhs = parseModuleType p in let endPos = p.prevEndPos in - let modType = List.fold_right (fun (attrs, name, moduleType, startPos) acc -> - Ast_helper.Mty.functor_ - ~loc:(mkLoc startPos endPos) - ~attrs - name moduleType acc - ) args rhs + let modType = + List.fold_right + (fun (attrs, name, moduleType, startPos) acc -> + Ast_helper.Mty.functor_ ~loc:(mkLoc startPos endPos) ~attrs name + moduleType acc) + args rhs in {modType with pmty_loc = mkLoc startPos endPos} @@ -5939,28 +6020,25 @@ and parseFunctorModuleType p = * | module-type with-mod-constraints * | extension *) - and parseModuleType ?(es6Arrow=true) ?(with_=true) p = +and parseModuleType ?(es6Arrow = true) ?(with_ = true) p = let attrs = parseAttributes p in - let modty = if es6Arrow && isEs6ArrowFunctor p then - parseFunctorModuleType p - else - let modty = parseAtomicModuleType p in - match p.Parser.token with - | EqualGreater when es6Arrow == true -> - Parser.next p; - let rhs = parseModuleType ~with_:false p in - let str = Location.mknoloc "_" in - let loc = mkLoc modty.pmty_loc.loc_start p.prevEndPos in - Ast_helper.Mty.functor_ ~loc str (Some modty) rhs - | _ -> modty + let modty = + if es6Arrow && isEs6ArrowFunctor p then parseFunctorModuleType p + else + let modty = parseAtomicModuleType p in + match p.Parser.token with + | EqualGreater when es6Arrow == true -> + Parser.next p; + let rhs = parseModuleType ~with_:false p in + let str = Location.mknoloc "_" in + let loc = mkLoc modty.pmty_loc.loc_start p.prevEndPos in + Ast_helper.Mty.functor_ ~loc str (Some modty) rhs + | _ -> modty in - let moduleType = { modty with - pmty_attributes = List.concat [modty.pmty_attributes; attrs] - } in - if with_ then - parseWithConstraints moduleType p - else moduleType - + let moduleType = + {modty with pmty_attributes = List.concat [modty.pmty_attributes; attrs]} + in + if with_ then parseWithConstraints moduleType p else moduleType and parseWithConstraints moduleType p = match p.Parser.token with @@ -5971,15 +6049,13 @@ and parseWithConstraints moduleType p = match p.Parser.token with | And -> Parser.next p; - loop p ((parseWithConstraint p)::acc) - | _ -> - List.rev acc + loop p (parseWithConstraint p :: acc) + | _ -> List.rev acc in let constraints = loop p [first] in let loc = mkLoc moduleType.pmty_loc.loc_start p.prevEndPos in Ast_helper.Mty.with_ ~loc moduleType constraints - | _ -> - moduleType + | _ -> moduleType (* mod-constraint ::= * | type typeconstr type-equation type-constraints? @@ -5990,10 +6066,10 @@ and parseWithConstraints moduleType p = * TODO: split this up into multiple functions, better errors *) and parseWithConstraint p = match p.Parser.token with - | Module -> + | Module -> ( Parser.next p; let modulePath = parseModuleLongIdent ~lowercase:false p in - begin match p.Parser.token with + match p.Parser.token with | ColonEqual -> Parser.next p; let lident = parseModuleLongIdent ~lowercase:false p in @@ -6006,63 +6082,45 @@ and parseWithConstraint p = (* TODO: revisit *) Parser.err p (Diagnostics.unexpected token p.breadcrumbs); let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_modsubst (modulePath, lident) - end - | Typ -> + Parsetree.Pwith_modsubst (modulePath, lident)) + | Typ -> ( Parser.next p; let typeConstr = parseValuePath p in let params = parseTypeParams ~parent:typeConstr p in - begin match p.Parser.token with + match p.Parser.token with | ColonEqual -> Parser.next p; let typExpr = parseTypExpr p in - Parsetree.Pwith_typesubst ( - typeConstr, - Ast_helper.Type.mk - ~loc:typeConstr.loc - ~params - ~manifest:typExpr - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) - ) + Parsetree.Pwith_typesubst + ( typeConstr, + Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr + (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) ) | Equal -> Parser.next p; let typExpr = parseTypExpr p in let typeConstraints = parseTypeConstraints p in - Parsetree.Pwith_type ( - typeConstr, - Ast_helper.Type.mk - ~loc:typeConstr.loc - ~params - ~manifest:typExpr - ~cstrs:typeConstraints - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) - ) + Parsetree.Pwith_type + ( typeConstr, + Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr + ~cstrs:typeConstraints + (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) ) | token -> (* TODO: revisit *) Parser.err p (Diagnostics.unexpected token p.breadcrumbs); let typExpr = parseTypExpr p in let typeConstraints = parseTypeConstraints p in - Parsetree.Pwith_type ( - typeConstr, - Ast_helper.Type.mk - ~loc:typeConstr.loc - ~params - ~manifest:typExpr - ~cstrs:typeConstraints - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) - ) - end + Parsetree.Pwith_type + ( typeConstr, + Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr + ~cstrs:typeConstraints + (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) )) | token -> (* TODO: implement recovery strategy *) Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Parsetree.Pwith_type ( - (Location.mknoloc (Longident.Lident "")), - Ast_helper.Type.mk - ~params:[] - ~manifest:(Recover.defaultType ()) - ~cstrs:[] - (Location.mknoloc "") - ) + Parsetree.Pwith_type + ( Location.mknoloc (Longident.Lident ""), + Ast_helper.Type.mk ~params:[] ~manifest:(Recover.defaultType ()) + ~cstrs:[] (Location.mknoloc "") ) and parseModuleTypeOf p = let startPos = p.Parser.startPos in @@ -6074,16 +6132,14 @@ and parseModuleTypeOf p = and parseNewlineOrSemicolonSignature p = match p.Parser.token with - | Semicolon -> - Parser.next p + | Semicolon -> Parser.next p | token when Grammar.isSignatureItemStart token -> if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () else - Parser.err - ~startPos:p.prevEndPos - ~endPos: p.endPos - p - (Diagnostics.message "consecutive specifications on a line must be separated by ';' or a newline") + Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p + (Diagnostics.message + "consecutive specifications on a line must be separated by ';' or a \ + newline") | _ -> () and parseSignatureItemRegion p = @@ -6097,20 +6153,19 @@ and parseSignatureItemRegion p = let loc = mkLoc startPos p.prevEndPos in Parser.endRegion p; Some (Ast_helper.Sig.value ~loc valueDesc) - | Typ -> + | Typ -> ( Parser.beginRegion p; - begin match parseTypeDefinitionOrExtension ~attrs p with + match parseTypeDefinitionOrExtension ~attrs p with | TypeDef {recFlag; types} -> parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in Parser.endRegion p; Some (Ast_helper.Sig.type_ ~loc recFlag types) - | TypeExt(ext) -> + | TypeExt ext -> parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in Parser.endRegion p; - Some (Ast_helper.Sig.type_extension ~loc ext) - end + Some (Ast_helper.Sig.type_extension ~loc ext)) | External -> let externalDef = parseExternalDef ~attrs ~startPos p in parseNewlineOrSemicolonSignature p; @@ -6134,18 +6189,16 @@ and parseSignatureItemRegion p = | Include -> Parser.next p; let moduleType = parseModuleType p in - let includeDescription = Ast_helper.Incl.mk - ~loc:(mkLoc startPos p.prevEndPos) - ~attrs - moduleType + let includeDescription = + Ast_helper.Incl.mk ~loc:(mkLoc startPos p.prevEndPos) ~attrs moduleType in parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in Some (Ast_helper.Sig.include_ ~loc includeDescription) - | Module -> + | Module -> ( Parser.beginRegion p; Parser.next p; - begin match p.Parser.token with + match p.Parser.token with | Uident _ -> let modDecl = parseModuleDeclarationOrAlias ~attrs p in parseNewlineOrSemicolonSignature p; @@ -6167,8 +6220,7 @@ and parseSignatureItemRegion p = parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in Parser.endRegion p; - Some (Ast_helper.Sig.module_ ~loc modDecl) - end + Some (Ast_helper.Sig.module_ ~loc modDecl)) | AtAt -> let attr = parseStandaloneAttribute p in parseNewlineOrSemicolonSignature p; @@ -6182,19 +6234,14 @@ and parseSignatureItemRegion p = | Import -> Parser.next p; parseSignatureItemRegion p - | _ -> - begin match attrs with - | (({Asttypes.loc = attrLoc}, _) as attr)::_ -> - Parser.err - ~startPos:attrLoc.loc_start - ~endPos:attrLoc.loc_end - p - (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); - Some Recover.defaultSignatureItem - | _ -> - None - end - [@@progress (Parser.next, Parser.expect)] + | _ -> ( + match attrs with + | (({Asttypes.loc = attrLoc}, _) as attr) :: _ -> + Parser.err ~startPos:attrLoc.loc_start ~endPos:attrLoc.loc_end p + (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); + Some Recover.defaultSignatureItem + | _ -> None) + [@@progress Parser.next, Parser.expect] (* module rec module-name : module-type { and module-name: module-type } *) and parseRecModuleSpec ~attrs ~startPos p = @@ -6212,23 +6259,23 @@ and parseRecModuleSpec ~attrs ~startPos p = *) Parser.expect And p; let decl = parseRecModuleDeclaration ~attrs ~startPos p in - loop p (decl::spec) - | _ -> - List.rev spec + loop p (decl :: spec) + | _ -> List.rev spec in let first = parseRecModuleDeclaration ~attrs ~startPos p in loop p [first] (* module-name : module-type *) and parseRecModuleDeclaration ~attrs ~startPos p = - let name = match p.Parser.token with - | Uident modName -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc modName loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + let name = + match p.Parser.token with + | Uident modName -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc modName loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in Parser.expect Colon p; let modType = parseModuleType p in @@ -6236,50 +6283,54 @@ and parseRecModuleDeclaration ~attrs ~startPos p = and parseModuleDeclarationOrAlias ~attrs p = let startPos = p.Parser.startPos in - let moduleName = match p.Parser.token with - | Uident ident -> - let loc = mkLoc p.Parser.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + let moduleName = + match p.Parser.token with + | Uident ident -> + let loc = mkLoc p.Parser.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in - let body = match p.Parser.token with - | Colon -> - Parser.next p; - parseModuleType p - | Equal -> - Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in - Ast_helper.Mty.alias lident - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleType() + let body = + match p.Parser.token with + | Colon -> + Parser.next p; + parseModuleType p + | Equal -> + Parser.next p; + let lident = parseModuleLongIdent ~lowercase:false p in + Ast_helper.Mty.alias lident + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultModuleType () in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Md.mk ~loc ~attrs moduleName body and parseModuleTypeDeclaration ~attrs ~startPos p = Parser.expect Typ p; - let moduleName = match p.Parser.token with - | Uident ident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc - | Lident ident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + let moduleName = + match p.Parser.token with + | Uident ident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc + | Lident ident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in - let typ = match p.Parser.token with - | Equal -> - Parser.next p; - Some (parseModuleType p) - | _ -> None + let typ = + match p.Parser.token with + | Equal -> + Parser.next p; + Some (parseModuleType p) + | _ -> None in let moduleDecl = Ast_helper.Mtd.mk ~attrs ?typ moduleName in Ast_helper.Sig.modtype ~loc:(mkLoc startPos p.prevEndPos) moduleDecl @@ -6287,33 +6338,35 @@ and parseModuleTypeDeclaration ~attrs ~startPos p = and parseSignLetDesc ~attrs p = let startPos = p.Parser.startPos in Parser.optional p Let |> ignore; - let (name, loc) = parseLident p in + let name, loc = parseLident p in let name = Location.mkloc name loc in Parser.expect Colon p; let typExpr = parsePolyTypeExpr p in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Val.mk ~loc ~attrs name typExpr -(* attr-id ::= lowercase-ident -∣ capitalized-ident -∣ attr-id . attr-id *) +(* attr-id ::= lowercase-ident + ∣ capitalized-ident + ∣ attr-id . attr-id *) and parseAttributeId ~startPos p = let rec loop p acc = match p.Parser.token with - | Lident ident | Uident ident -> + | Lident ident | Uident ident -> ( Parser.next p; let id = acc ^ ident in - begin match p.Parser.token with - | Dot -> Parser.next p; loop p (id ^ ".") - | _ -> id - end - | token when Token.isKeyword token -> + match p.Parser.token with + | Dot -> + Parser.next p; + loop p (id ^ ".") + | _ -> id) + | token when Token.isKeyword token -> ( Parser.next p; - let id = acc ^ (Token.toString token) in - begin match p.Parser.token with - | Dot -> Parser.next p; loop p (id ^ ".") - | _ -> id - end + let id = acc ^ Token.toString token in + match p.Parser.token with + | Dot -> + Parser.next p; + loop p (id ^ ".") + | _ -> id) | token -> Parser.err p (Diagnostics.unexpected token p.breadcrumbs); acc @@ -6334,22 +6387,18 @@ and parseAttributeId ~startPos p = *) and parsePayload p = match p.Parser.token with - | Lparen when p.startPos.pos_cnum = p.prevEndPos.pos_cnum -> + | Lparen when p.startPos.pos_cnum = p.prevEndPos.pos_cnum -> ( Parser.leaveBreadcrumb p Grammar.AttributePayload; Parser.next p; - begin match p.token with + match p.token with | Colon -> Parser.next p; - let payload = if Grammar.isSignatureItemStart p.token then - Parsetree.PSig ( - parseDelimitedRegion - ~grammar:Grammar.Signature - ~closing:Rparen - ~f:parseSignatureItemRegion - p - ) - else - Parsetree.PTyp (parseTypExpr p) + let payload = + if Grammar.isSignatureItemStart p.token then + Parsetree.PSig + (parseDelimitedRegion ~grammar:Grammar.Signature ~closing:Rparen + ~f:parseSignatureItemRegion p) + else Parsetree.PTyp (parseTypExpr p) in Parser.expect Rparen p; Parser.eatBreadcrumb p; @@ -6357,27 +6406,24 @@ and parsePayload p = | Question -> Parser.next p; let pattern = parsePattern p in - let expr = match p.token with - | When | If -> - Parser.next p; - Some (parseExpr p) - | _ -> - None + let expr = + match p.token with + | When | If -> + Parser.next p; + Some (parseExpr p) + | _ -> None in Parser.expect Rparen p; Parser.eatBreadcrumb p; Parsetree.PPat (pattern, expr) | _ -> - let items = parseDelimitedRegion - ~grammar:Grammar.Structure - ~closing:Rparen - ~f:parseStructureItemRegion - p + let items = + parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rparen + ~f:parseStructureItemRegion p in Parser.expect Rparen p; Parser.eatBreadcrumb p; - Parsetree.PStr items - end + Parsetree.PStr items) | _ -> Parsetree.PStr [] (* type attribute = string loc * payload *) @@ -6388,17 +6434,20 @@ and parseAttribute p = Parser.next p; let attrId = parseAttributeId ~startPos p in let payload = parsePayload p in - Some(attrId, payload) - | DocComment (loc, s) -> - Parser.next p; - Some ({txt="ns.doc"; loc}, - PStr [Ast_helper.Str.eval ~loc (Ast_helper.Exp.constant ~loc (Pconst_string(s, None)) )]) + Some (attrId, payload) + | DocComment (loc, s) -> + Parser.next p; + Some + ( {txt = "ns.doc"; loc}, + PStr + [ + Ast_helper.Str.eval ~loc + (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); + ] ) | _ -> None and parseAttributes p = - parseRegion p - ~grammar:Grammar.Attribute - ~f:parseAttribute + parseRegion p ~grammar:Grammar.Attribute ~f:parseAttribute (* * standalone-attribute ::= @@ -6445,12 +6494,10 @@ and parseStandaloneAttribute p = * * ~moduleLanguage represents whether we're on the module level or not *) -and parseExtension ?(moduleLanguage=false) p = +and parseExtension ?(moduleLanguage = false) p = let startPos = p.Parser.startPos in - if moduleLanguage then - Parser.expect PercentPercent p - else - Parser.expect Percent p; + if moduleLanguage then Parser.expect PercentPercent p + else Parser.expect Percent p; let attrId = parseAttributeId ~startPos p in let payload = parsePayload p in (attrId, payload) @@ -6461,4 +6508,4 @@ let parseSpecification p : Parsetree.signature = (* module structure on the file level *) let parseImplementation p : Parsetree.structure = - parseRegion p ~grammar:Grammar.Implementation ~f:parseStructureItemRegion \ No newline at end of file + parseRegion p ~grammar:Grammar.Implementation ~f:parseStructureItemRegion diff --git a/src/res_core.mli b/src/res_core.mli index 760881cd..e77ca30b 100644 --- a/src/res_core.mli +++ b/src/res_core.mli @@ -1,4 +1,2 @@ -val parseImplementation: - Res_parser.t -> Parsetree.structure -val parseSpecification: - Res_parser.t -> Parsetree.signature +val parseImplementation : Res_parser.t -> Parsetree.structure +val parseSpecification : Res_parser.t -> Parsetree.signature diff --git a/src/res_diagnostics.ml b/src/res_diagnostics.ml index 843d3e42..dc6ea559 100644 --- a/src/res_diagnostics.ml +++ b/src/res_diagnostics.ml @@ -3,7 +3,11 @@ module Token = Res_token type category = | Unexpected of {token: Token.t; context: (Grammar.t * Lexing.position) list} - | Expected of {context: Grammar.t option; pos: Lexing.position (* prev token end*); token: Token.t} + | Expected of { + context: Grammar.t option; + pos: Lexing.position; (* prev token end*) + token: Token.t; + } | Message of string | Uident of Token.t | Lident of Token.t @@ -24,154 +28,141 @@ let getStartPos t = t.startPos let getEndPos t = t.endPos let defaultUnexpected token = - "I'm not sure what to parse here when looking at \"" ^ (Token.toString token) ^ "\"." + "I'm not sure what to parse here when looking at \"" ^ Token.toString token + ^ "\"." let reservedKeyword token = let tokenTxt = Token.toString token in - "`" ^ tokenTxt ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ tokenTxt ^ "\"" + "`" ^ tokenTxt ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" + ^ tokenTxt ^ "\"" let explain t = match t.category with - | Uident currentToken -> - begin match currentToken with + | Uident currentToken -> ( + match currentToken with | Lident lident -> let guess = String.capitalize_ascii lident in - "Did you mean `" ^ guess ^"` instead of `" ^ lident ^ "`?" + "Did you mean `" ^ guess ^ "` instead of `" ^ lident ^ "`?" | t when Token.isKeyword t -> let token = Token.toString t in "`" ^ token ^ "` is a reserved keyword." | _ -> "At this point, I'm looking for an uppercased name like `Belt` or `Array`" - end - | Lident currentToken -> - begin match currentToken with + ) + | Lident currentToken -> ( + match currentToken with | Uident uident -> let guess = String.uncapitalize_ascii uident in - "Did you mean `" ^ guess ^"` instead of `" ^ uident ^ "`?" + "Did you mean `" ^ guess ^ "` instead of `" ^ uident ^ "`?" | t when Token.isKeyword t -> let token = Token.toString t in - "`" ^ token ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ token ^ "\"" - | Underscore -> - "`_` isn't a valid name." - | _ -> - "I'm expecting a lowercase name like `user or `age`" - end + "`" ^ token ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" + ^ token ^ "\"" + | Underscore -> "`_` isn't a valid name." + | _ -> "I'm expecting a lowercase name like `user or `age`") | Message txt -> txt - | UnclosedString -> - "This string is missing a double quote at the end" + | UnclosedString -> "This string is missing a double quote at the end" | UnclosedTemplate -> "Did you forget to close this template expression with a backtick?" - | UnclosedComment -> - "This comment seems to be missing a closing `*/`" - | UnknownUchar uchar -> - begin match uchar with + | UnclosedComment -> "This comment seems to be missing a closing `*/`" + | UnknownUchar uchar -> ( + match uchar with | '^' -> - "Not sure what to do with this character.\n" ^ - " If you're trying to dereference a mutable value, use `myValue.contents` instead.\n" ^ - " To concatenate strings, use `\"a\" ++ \"b\"` instead." - | _ -> - "Not sure what to do with this character." - end + "Not sure what to do with this character.\n" + ^ " If you're trying to dereference a mutable value, use \ + `myValue.contents` instead.\n" + ^ " To concatenate strings, use `\"a\" ++ \"b\"` instead." + | _ -> "Not sure what to do with this character.") | Expected {context; token = t} -> - let hint = match context with - | Some grammar -> " It signals the start of " ^ (Grammar.toString grammar) - | None -> "" + let hint = + match context with + | Some grammar -> " It signals the start of " ^ Grammar.toString grammar + | None -> "" in - "Did you forget a `" ^ (Token.toString t) ^ "` here?" ^ hint - | Unexpected {token = t; context = breadcrumbs} -> - let name = (Token.toString t) in - begin match breadcrumbs with - | (AtomicTypExpr, _)::breadcrumbs -> - begin match breadcrumbs, t with - | ((StringFieldDeclarations | FieldDeclarations) , _) :: _, (String _ | At | Rbrace | Comma | Eof) -> - "I'm missing a type here" - | _, t when Grammar.isStructureItemStart t || t = Eof -> - "Missing a type here" - | _ -> - defaultUnexpected t - end - | (ExprOperand, _)::breadcrumbs -> - begin match breadcrumbs, t with - | (ExprBlock, _) :: _, Rbrace -> - "It seems that this expression block is empty" - | (ExprBlock, _) :: _, Bar -> (* Pattern matching *) - "Looks like there might be an expression missing here" - | (ExprSetField, _) :: _, _ -> - "It seems that this record field mutation misses an expression" - | (ExprArrayMutation, _) :: _, _ -> - "Seems that an expression is missing, with what do I mutate the array?" - | ((ExprBinaryAfterOp _ | ExprUnary), _) ::_, _ -> - "Did you forget to write an expression here?" - | (Grammar.LetBinding, _)::_, _ -> - "This let-binding misses an expression" - | _::_, (Rbracket | Rbrace | Eof) -> - "Missing expression" - | _ -> - "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." - end - | (TypeParam, _)::_ -> - begin match t with - | Lident ident -> - "Did you mean '" ^ ident ^"? A Type parameter starts with a quote." - | _ -> - "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." - end - | (Pattern, _)::breadcrumbs -> - begin match t, breadcrumbs with - | (Equal, (LetBinding,_)::_) -> - "I was expecting a name for this let-binding. Example: `let message = \"hello\"`" - | (In, (ExprFor,_)::_) -> - "A for-loop has the following form: `for i in 0 to 10`. Did you forget to supply a name before `in`?" - | (EqualGreater, (PatternMatchCase,_)::_) -> + "Did you forget a `" ^ Token.toString t ^ "` here?" ^ hint + | Unexpected {token = t; context = breadcrumbs} -> ( + let name = Token.toString t in + match breadcrumbs with + | (AtomicTypExpr, _) :: breadcrumbs -> ( + match (breadcrumbs, t) with + | ( ((StringFieldDeclarations | FieldDeclarations), _) :: _, + (String _ | At | Rbrace | Comma | Eof) ) -> + "I'm missing a type here" + | _, t when Grammar.isStructureItemStart t || t = Eof -> + "Missing a type here" + | _ -> defaultUnexpected t) + | (ExprOperand, _) :: breadcrumbs -> ( + match (breadcrumbs, t) with + | (ExprBlock, _) :: _, Rbrace -> + "It seems that this expression block is empty" + | (ExprBlock, _) :: _, Bar -> + (* Pattern matching *) + "Looks like there might be an expression missing here" + | (ExprSetField, _) :: _, _ -> + "It seems that this record field mutation misses an expression" + | (ExprArrayMutation, _) :: _, _ -> + "Seems that an expression is missing, with what do I mutate the array?" + | ((ExprBinaryAfterOp _ | ExprUnary), _) :: _, _ -> + "Did you forget to write an expression here?" + | (Grammar.LetBinding, _) :: _, _ -> + "This let-binding misses an expression" + | _ :: _, (Rbracket | Rbrace | Eof) -> "Missing expression" + | _ -> "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." + ) + | (TypeParam, _) :: _ -> ( + match t with + | Lident ident -> + "Did you mean '" ^ ident ^ "? A Type parameter starts with a quote." + | _ -> "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." + ) + | (Pattern, _) :: breadcrumbs -> ( + match (t, breadcrumbs) with + | Equal, (LetBinding, _) :: _ -> + "I was expecting a name for this let-binding. Example: `let message = \ + \"hello\"`" + | In, (ExprFor, _) :: _ -> + "A for-loop has the following form: `for i in 0 to 10`. Did you forget \ + to supply a name before `in`?" + | EqualGreater, (PatternMatchCase, _) :: _ -> "I was expecting a pattern to match on before the `=>`" - | (token, _) when Token.isKeyword t -> - reservedKeyword token - | (token, _) -> - defaultUnexpected token - end + | token, _ when Token.isKeyword t -> reservedKeyword token + | token, _ -> defaultUnexpected token) | _ -> (* TODO: match on circumstance to verify Lident needed ? *) if Token.isKeyword t then - "`" ^ name ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ (Token.toString t) ^ "\"" - else - "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." - end + "`" ^ name + ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" + ^ Token.toString t ^ "\"" + else "I'm not sure what to parse here when looking at \"" ^ name ^ "\".") -let make ~startPos ~endPos category = { - startPos; - endPos; - category -} +let make ~startPos ~endPos category = {startPos; endPos; category} let printReport diagnostics src = let rec print diagnostics src = match diagnostics with | [] -> () - | d::rest -> + | d :: rest -> Res_diagnostics_printing_utils.Super_location.super_error_reporter - Format.err_formatter - src - Location.{ - loc = {loc_start = d.startPos; loc_end = d.endPos; loc_ghost = false}; - msg = explain d; - sub = []; - if_highlight = ""; - }; - begin match rest with + Format.err_formatter src + Location. + { + loc = {loc_start = d.startPos; loc_end = d.endPos; loc_ghost = false}; + msg = explain d; + sub = []; + if_highlight = ""; + }; + (match rest with | [] -> () - | _ -> Format.fprintf Format.err_formatter "@." - end; + | _ -> Format.fprintf Format.err_formatter "@."); print rest src in Format.fprintf Format.err_formatter "@["; print (List.rev diagnostics) src; Format.fprintf Format.err_formatter "@]@." -let unexpected token context = - Unexpected {token; context} +let unexpected token context = Unexpected {token; context} -let expected ?grammar pos token = - Expected {context = grammar; pos; token} +let expected ?grammar pos token = Expected {context = grammar; pos; token} let uident currentToken = Uident currentToken let lident currentToken = Lident currentToken diff --git a/src/res_diagnostics.mli b/src/res_diagnostics.mli index 7855a984..0ae74cec 100644 --- a/src/res_diagnostics.mli +++ b/src/res_diagnostics.mli @@ -5,25 +5,21 @@ type t type category type report -val getStartPos: t -> Lexing.position [@@live] (* for playground *) -val getEndPos: t -> Lexing.position [@@live] (* for playground *) +val getStartPos : t -> Lexing.position [@@live] (* for playground *) +val getEndPos : t -> Lexing.position [@@live] (* for playground *) -val explain: t -> string [@@live] (* for playground *) +val explain : t -> string [@@live] (* for playground *) -val unexpected: Token.t -> (Grammar.t * Lexing.position) list -> category -val expected: ?grammar:Grammar.t -> Lexing.position -> Token.t -> category -val uident: Token.t -> category -val lident: Token.t -> category -val unclosedString: category -val unclosedTemplate: category -val unclosedComment: category -val unknownUchar: Char.t -> category -val message: string -> category +val unexpected : Token.t -> (Grammar.t * Lexing.position) list -> category +val expected : ?grammar:Grammar.t -> Lexing.position -> Token.t -> category +val uident : Token.t -> category +val lident : Token.t -> category +val unclosedString : category +val unclosedTemplate : category +val unclosedComment : category +val unknownUchar : Char.t -> category +val message : string -> category -val make: - startPos: Lexing.position - -> endPos: Lexing.position - -> category - -> t +val make : startPos:Lexing.position -> endPos:Lexing.position -> category -> t -val printReport: t list -> string -> unit +val printReport : t list -> string -> unit diff --git a/src/res_diagnostics_printing_utils.ml b/src/res_diagnostics_printing_utils.ml index 758478a4..74d23e40 100644 --- a/src/res_diagnostics_printing_utils.ml +++ b/src/res_diagnostics_printing_utils.ml @@ -8,123 +8,120 @@ (* ===== super_code_frame.ml *) module Super_code_frame = struct + let digits_count n = + let rec loop n base count = + if n >= base then loop n (base * 10) (count + 1) else count + in + loop (abs n) 1 0 -let digits_count n = - let rec loop n base count = - if n >= base then loop n (base * 10) (count + 1) else count - in - loop (abs n) 1 0 + let seek_2_lines_before src pos = + let open Lexing in + let original_line = pos.pos_lnum in + let rec loop current_line current_char = + if current_line + 2 >= original_line then (current_char, current_line) + else + loop + (if (src.[current_char] [@doesNotRaise]) = '\n' then current_line + 1 + else current_line) + (current_char + 1) + in + loop 1 0 -let seek_2_lines_before src pos = - let open Lexing in - let original_line = pos.pos_lnum in - let rec loop current_line current_char = - if current_line + 2 >= original_line then - (current_char, current_line) - else - loop - (if (src.[current_char] [@doesNotRaise]) = '\n' then current_line + 1 else current_line) - (current_char + 1) - in - loop 1 0 + let seek_2_lines_after src pos = + let open Lexing in + let original_line = pos.pos_lnum in + let rec loop current_line current_char = + if current_char = String.length src then (current_char, current_line) + else + match src.[current_char] [@doesNotRaise] with + | '\n' when current_line = original_line + 2 -> + (current_char, current_line) + | '\n' -> loop (current_line + 1) (current_char + 1) + | _ -> loop current_line (current_char + 1) + in + loop original_line pos.pos_cnum -let seek_2_lines_after src pos = - let open Lexing in - let original_line = pos.pos_lnum in - let rec loop current_line current_char = - if current_char = String.length src then - (current_char, current_line) - else - match src.[current_char] [@doesNotRaise] with - | '\n' when current_line = original_line + 2 -> - (current_char, current_line) - | '\n' -> loop (current_line + 1) (current_char + 1) - | _ -> loop current_line (current_char + 1) - in - loop original_line pos.pos_cnum + let leading_space_count str = + let rec loop i count = + if i = String.length str then count + else if (str.[i] [@doesNotRaise]) != ' ' then count + else loop (i + 1) (count + 1) + in + loop 0 0 -let leading_space_count str = - let rec loop i count = - if i = String.length str then count - else if str.[i] [@doesNotRaise] != ' ' then count - else loop (i + 1) (count + 1) - in - loop 0 0 + let break_long_line max_width line = + let rec loop pos accum = + if pos = String.length line then accum + else + let chunk_length = min max_width (String.length line - pos) in + let chunk = (String.sub [@doesNotRaise]) line pos chunk_length in + loop (pos + chunk_length) (chunk :: accum) + in + loop 0 [] |> List.rev -let break_long_line max_width line = - let rec loop pos accum = - if pos = String.length line then accum - else - let chunk_length = min max_width (String.length line - pos) in - let chunk = (String.sub [@doesNotRaise]) line pos chunk_length in - loop (pos + chunk_length) (chunk::accum) - in - loop 0 [] |> List.rev + let filter_mapi f l = + let rec loop f l i accum = + match l with + | [] -> accum + | head :: rest -> + let accum = + match f i head with + | None -> accum + | Some result -> result :: accum + in + loop f rest (i + 1) accum + in + loop f l 0 [] |> List.rev -let filter_mapi f l = - let rec loop f l i accum = - match l with - | [] -> accum - | head::rest -> - let accum = - match f i head with - | None -> accum - | Some result -> result::accum - in - loop f rest (i + 1) accum - in - loop f l 0 [] |> List.rev + (* Spiritual equivalent of + https://github.com/ocaml/ocaml/blob/414bdec9ae387129b8102cc6bf3c0b6ae173eeb9/utils/misc.ml#L601 + *) + module Color = struct + type color = + | Dim + (* | Filename *) + | Err + | Warn + | NoColor -(* Spiritual equivalent of - https://github.com/ocaml/ocaml/blob/414bdec9ae387129b8102cc6bf3c0b6ae173eeb9/utils/misc.ml#L601 -*) -module Color = struct - type color = - | Dim - (* | Filename *) - | Err - | Warn - | NoColor + let dim = "\x1b[2m" + + (* let filename = "\x1b[46m" *) + let err = "\x1b[1;31m" + let warn = "\x1b[1;33m" + let reset = "\x1b[0m" - let dim = "\x1b[2m" - (* let filename = "\x1b[46m" *) - let err = "\x1b[1;31m" - let warn = "\x1b[1;33m" - let reset = "\x1b[0m" + external isatty : out_channel -> bool = "caml_sys_isatty" - external isatty : out_channel -> bool = "caml_sys_isatty" - (* reasonable heuristic on whether colors should be enabled *) - let should_enable_color () = - let term = try Sys.getenv "TERM" with Not_found -> "" in - term <> "dumb" - && term <> "" - && isatty stderr + (* reasonable heuristic on whether colors should be enabled *) + let should_enable_color () = + let term = try Sys.getenv "TERM" with Not_found -> "" in + term <> "dumb" && term <> "" && isatty stderr - let color_enabled = ref true + let color_enabled = ref true - let setup = - let first = ref true in (* initialize only once *) - fun o -> - if !first then ( - first := false; - color_enabled := (match o with + let setup = + let first = ref true in + (* initialize only once *) + fun o -> + if !first then ( + first := false; + color_enabled := + match o with | Some Misc.Color.Always -> true | Some Auto -> should_enable_color () | Some Never -> false - | None -> should_enable_color ()) - ); - () -end + | None -> should_enable_color ()); + () + end -let setup = Color.setup + let setup = Color.setup -type gutter = Number of int | Elided -type highlighted_string = {s: string; start: int; end_: int} -type line = { - gutter: gutter; - content: highlighted_string list; -} -(* + type gutter = Number of int | Elided + type highlighted_string = {s: string; start: int; end_: int} + type line = {gutter: gutter; content: highlighted_string list} + + (* Features: - display a line gutter - break long line into multiple for terminal display @@ -132,242 +129,261 @@ type line = { - center snippet when it's heavily indented - ellide intermediate lines when the reported range is huge *) -let print ~is_warning ~src ~startPos ~endPos = - let open Lexing in - - let indent = 2 in - let highlight_line_start_line = startPos.pos_lnum in - let highlight_line_end_line = endPos.pos_lnum in - let (start_line_line_offset, first_shown_line) = seek_2_lines_before src startPos in - let (end_line_line_end_offset, last_shown_line) = seek_2_lines_after src endPos in + let print ~is_warning ~src ~startPos ~endPos = + let open Lexing in + let indent = 2 in + let highlight_line_start_line = startPos.pos_lnum in + let highlight_line_end_line = endPos.pos_lnum in + let start_line_line_offset, first_shown_line = + seek_2_lines_before src startPos + in + let end_line_line_end_offset, last_shown_line = + seek_2_lines_after src endPos + in - let more_than_5_highlighted_lines = - highlight_line_end_line - highlight_line_start_line + 1 > 5 - in - let max_line_digits_count = digits_count last_shown_line in - (* TODO: change this back to a fixed 100? *) - (* 3 for separator + the 2 spaces around it *) - let line_width = 78 - max_line_digits_count - indent - 3 in - let lines = - (String.sub [@doesNotRaise]) src start_line_line_offset (end_line_line_end_offset - start_line_line_offset) - |> String.split_on_char '\n' - |> filter_mapi (fun i line -> - let line_number = i + first_shown_line in - if more_than_5_highlighted_lines then - if line_number = highlight_line_start_line + 2 then - Some (Elided, line) - else if line_number > highlight_line_start_line + 2 && line_number < highlight_line_end_line - 1 then None - else Some (Number line_number, line) - else Some (Number line_number, line) - ) - in - let leading_space_to_cut = lines |> List.fold_left (fun current_max (_, line) -> - let leading_spaces = leading_space_count line in - if String.length line = leading_spaces then - (* the line's nothing but spaces. Doesn't count *) - current_max - else - min leading_spaces current_max - ) 99999 - in - let separator = if leading_space_to_cut = 0 then "│" else "┆" in - let stripped_lines = lines |> List.map (fun (gutter, line) -> - let new_content = - if String.length line <= leading_space_to_cut then - [{s = ""; start = 0; end_ = 0}] - else - (String.sub [@doesNotRaise]) line leading_space_to_cut (String.length line - leading_space_to_cut) - |> break_long_line line_width - |> List.mapi (fun i line -> - match gutter with - | Elided -> {s = line; start = 0; end_ = 0} - | Number line_number -> - let highlight_line_start_offset = startPos.pos_cnum - startPos.pos_bol in - let highlight_line_end_offset = endPos.pos_cnum - endPos.pos_bol in - let start = - if i = 0 && line_number = highlight_line_start_line then - highlight_line_start_offset - leading_space_to_cut - else 0 - in - let end_ = - if line_number < highlight_line_start_line then 0 - else if line_number = highlight_line_start_line && line_number = highlight_line_end_line then - highlight_line_end_offset - leading_space_to_cut - else if line_number = highlight_line_start_line then - String.length line - else if line_number > highlight_line_start_line && line_number < highlight_line_end_line then - String.length line - else if line_number = highlight_line_end_line then highlight_line_end_offset - leading_space_to_cut - else 0 - in - {s = line; start; end_} - ) + let more_than_5_highlighted_lines = + highlight_line_end_line - highlight_line_start_line + 1 > 5 in - {gutter; content = new_content} - ) - in - let buf = Buffer.create 100 in - let open Color in - let add_ch = - let last_color = ref NoColor in - fun color ch -> - if not !Color.color_enabled || !last_color = color then - Buffer.add_char buf ch - else begin - let ansi = match !last_color, color with - | NoColor, Dim -> dim - (* | NoColor, Filename -> filename *) - | NoColor, Err -> err - | NoColor, Warn -> warn - | _, NoColor -> reset - | _, Dim -> reset ^ dim - (* | _, Filename -> reset ^ filename *) - | _, Err -> reset ^ err - | _, Warn -> reset ^ warn - in - Buffer.add_string buf ansi; - Buffer.add_char buf ch; - last_color := color; - end - in - let draw_gutter color s = - for _i = 1 to (max_line_digits_count + indent - String.length s) do + let max_line_digits_count = digits_count last_shown_line in + (* TODO: change this back to a fixed 100? *) + (* 3 for separator + the 2 spaces around it *) + let line_width = 78 - max_line_digits_count - indent - 3 in + let lines = + (String.sub [@doesNotRaise]) src start_line_line_offset + (end_line_line_end_offset - start_line_line_offset) + |> String.split_on_char '\n' + |> filter_mapi (fun i line -> + let line_number = i + first_shown_line in + if more_than_5_highlighted_lines then + if line_number = highlight_line_start_line + 2 then + Some (Elided, line) + else if + line_number > highlight_line_start_line + 2 + && line_number < highlight_line_end_line - 1 + then None + else Some (Number line_number, line) + else Some (Number line_number, line)) + in + let leading_space_to_cut = + lines + |> List.fold_left + (fun current_max (_, line) -> + let leading_spaces = leading_space_count line in + if String.length line = leading_spaces then + (* the line's nothing but spaces. Doesn't count *) + current_max + else min leading_spaces current_max) + 99999 + in + let separator = if leading_space_to_cut = 0 then "│" else "┆" in + let stripped_lines = + lines + |> List.map (fun (gutter, line) -> + let new_content = + if String.length line <= leading_space_to_cut then + [{s = ""; start = 0; end_ = 0}] + else + (String.sub [@doesNotRaise]) line leading_space_to_cut + (String.length line - leading_space_to_cut) + |> break_long_line line_width + |> List.mapi (fun i line -> + match gutter with + | Elided -> {s = line; start = 0; end_ = 0} + | Number line_number -> + let highlight_line_start_offset = + startPos.pos_cnum - startPos.pos_bol + in + let highlight_line_end_offset = + endPos.pos_cnum - endPos.pos_bol + in + let start = + if i = 0 && line_number = highlight_line_start_line + then + highlight_line_start_offset - leading_space_to_cut + else 0 + in + let end_ = + if line_number < highlight_line_start_line then 0 + else if + line_number = highlight_line_start_line + && line_number = highlight_line_end_line + then + highlight_line_end_offset - leading_space_to_cut + else if line_number = highlight_line_start_line then + String.length line + else if + line_number > highlight_line_start_line + && line_number < highlight_line_end_line + then String.length line + else if line_number = highlight_line_end_line then + highlight_line_end_offset - leading_space_to_cut + else 0 + in + {s = line; start; end_}) + in + {gutter; content = new_content}) + in + let buf = Buffer.create 100 in + let open Color in + let add_ch = + let last_color = ref NoColor in + fun color ch -> + if (not !Color.color_enabled) || !last_color = color then + Buffer.add_char buf ch + else + let ansi = + match (!last_color, color) with + | NoColor, Dim -> dim + (* | NoColor, Filename -> filename *) + | NoColor, Err -> err + | NoColor, Warn -> warn + | _, NoColor -> reset + | _, Dim -> reset ^ dim + (* | _, Filename -> reset ^ filename *) + | _, Err -> reset ^ err + | _, Warn -> reset ^ warn + in + Buffer.add_string buf ansi; + Buffer.add_char buf ch; + last_color := color + in + let draw_gutter color s = + for _i = 1 to max_line_digits_count + indent - String.length s do + add_ch NoColor ' ' + done; + s |> String.iter (add_ch color); + add_ch NoColor ' '; + separator |> String.iter (add_ch Dim); add_ch NoColor ' ' - done; - s |> String.iter (add_ch color); - add_ch NoColor ' '; - separator |> String.iter (add_ch Dim); - add_ch NoColor ' '; - in - stripped_lines |> List.iter (fun {gutter; content} -> - match gutter with - | Elided -> - draw_gutter Dim "."; - add_ch Dim '.'; - add_ch Dim '.'; - add_ch Dim '.'; - add_ch NoColor '\n'; - | Number line_number -> begin - content |> List.iteri (fun i line -> - let gutter_content = if i = 0 then string_of_int line_number else "" in - let gutter_color = - if i = 0 - && line_number >= highlight_line_start_line - && line_number <= highlight_line_end_line then - if is_warning then Warn else Err - else NoColor - in - draw_gutter gutter_color gutter_content; + in + stripped_lines + |> List.iter (fun {gutter; content} -> + match gutter with + | Elided -> + draw_gutter Dim "."; + add_ch Dim '.'; + add_ch Dim '.'; + add_ch Dim '.'; + add_ch NoColor '\n' + | Number line_number -> + content + |> List.iteri (fun i line -> + let gutter_content = + if i = 0 then string_of_int line_number else "" + in + let gutter_color = + if + i = 0 + && line_number >= highlight_line_start_line + && line_number <= highlight_line_end_line + then if is_warning then Warn else Err + else NoColor + in + draw_gutter gutter_color gutter_content; - line.s |> String.iteri (fun ii ch -> - let c = - if ii >= line.start && ii < line.end_ then - if is_warning then Warn else Err - else NoColor in - add_ch c ch; - ); - add_ch NoColor '\n'; - ); - end - ); - Buffer.contents buf + line.s + |> String.iteri (fun ii ch -> + let c = + if ii >= line.start && ii < line.end_ then + if is_warning then Warn else Err + else NoColor + in + add_ch c ch); + add_ch NoColor '\n')); + Buffer.contents buf end - (* ===== super_location.ml *) module Super_location = struct + let fprintf = Format.fprintf -let fprintf = Format.fprintf + let setup_colors () = + Misc.Color.setup !Clflags.color; + Super_code_frame.setup !Clflags.color -let setup_colors () = - Misc.Color.setup !Clflags.color; - Super_code_frame.setup !Clflags.color + let print_filename = Location.print_filename -let print_filename = Location.print_filename - -let print_loc ~normalizedRange ppf (loc : Location.t) = - setup_colors (); - let dim_loc ppf = function - | None -> () - | Some ((start_line, start_line_start_char), (end_line, end_line_end_char)) -> - if start_line = end_line then - if start_line_start_char = end_line_end_char then - fprintf ppf ":@{%i:%i@}" start_line start_line_start_char + let print_loc ~normalizedRange ppf (loc : Location.t) = + setup_colors (); + let dim_loc ppf = function + | None -> () + | Some ((start_line, start_line_start_char), (end_line, end_line_end_char)) + -> + if start_line = end_line then + if start_line_start_char = end_line_end_char then + fprintf ppf ":@{%i:%i@}" start_line start_line_start_char + else + fprintf ppf ":@{%i:%i-%i@}" start_line start_line_start_char + end_line_end_char else - fprintf ppf ":@{%i:%i-%i@}" start_line start_line_start_char end_line_end_char - else - fprintf ppf ":@{%i:%i-%i:%i@}" start_line start_line_start_char end_line end_line_end_char - in - fprintf ppf "@{%a@}%a" print_filename loc.loc_start.pos_fname dim_loc normalizedRange -;; - + fprintf ppf ":@{%i:%i-%i:%i@}" start_line start_line_start_char + end_line end_line_end_char + in + fprintf ppf "@{%a@}%a" print_filename loc.loc_start.pos_fname + dim_loc normalizedRange -(* let print ~message_kind intro ppf (loc : Location.t) = *) -let print ~message_kind intro src ppf (loc : Location.t) = - begin match message_kind with + (* let print ~message_kind intro ppf (loc : Location.t) = *) + let print ~message_kind intro src ppf (loc : Location.t) = + (match message_kind with | `warning -> fprintf ppf "@[@{%s@}@]@," intro - | `warning_as_error -> fprintf ppf "@[@{%s@} (configured as error) @]@," intro - | `error -> fprintf ppf "@[@{%s@}@]@," intro - end; - (* ocaml's reported line/col numbering is horrible and super error-prone - when being handled programmatically (or humanly for that matter. If you're - an ocaml contributor reading this: who the heck reads the character count - starting from the first erroring character?) *) - (* let (file, start_line, start_char) = Location.get_pos_info loc.loc_start in *) - let (_file, start_line, start_char) = Location.get_pos_info loc.loc_start in - let (_, end_line, end_char) = Location.get_pos_info loc.loc_end in - (* line is 1-indexed, column is 0-indexed. We convert all of them to 1-indexed to avoid confusion *) - (* start_char is inclusive, end_char is exclusive *) - let normalizedRange = - (* TODO: lots of the handlings here aren't needed anymore because the new - rescript syntax has much stronger invariants regarding positions, e.g. - no -1 *) - if start_char == -1 || end_char == -1 then - (* happens sometimes. Syntax error for example *) - None - else if start_line = end_line && start_char >= end_char then - (* in some errors, starting char and ending char can be the same. But - since ending char was supposed to be exclusive, here it might end up - smaller than the starting char if we naively did start_char + 1 to - just the starting char and forget ending char *) - let same_char = start_char + 1 in - Some ((start_line, same_char), (end_line, same_char)) - else - (* again: end_char is exclusive, so +1-1=0 *) - Some ((start_line, start_char + 1), (end_line, end_char)) - in - fprintf ppf " @[%a@]@," (print_loc ~normalizedRange) loc; - match normalizedRange with - | None -> () - | Some _ -> begin + | `warning_as_error -> + fprintf ppf "@[@{%s@} (configured as error) @]@," intro + | `error -> fprintf ppf "@[@{%s@}@]@," intro); + (* ocaml's reported line/col numbering is horrible and super error-prone + when being handled programmatically (or humanly for that matter. If you're + an ocaml contributor reading this: who the heck reads the character count + starting from the first erroring character?) *) + (* let (file, start_line, start_char) = Location.get_pos_info loc.loc_start in *) + let _file, start_line, start_char = Location.get_pos_info loc.loc_start in + let _, end_line, end_char = Location.get_pos_info loc.loc_end in + (* line is 1-indexed, column is 0-indexed. We convert all of them to 1-indexed to avoid confusion *) + (* start_char is inclusive, end_char is exclusive *) + let normalizedRange = + (* TODO: lots of the handlings here aren't needed anymore because the new + rescript syntax has much stronger invariants regarding positions, e.g. + no -1 *) + if start_char == -1 || end_char == -1 then + (* happens sometimes. Syntax error for example *) + None + else if start_line = end_line && start_char >= end_char then + (* in some errors, starting char and ending char can be the same. But + since ending char was supposed to be exclusive, here it might end up + smaller than the starting char if we naively did start_char + 1 to + just the starting char and forget ending char *) + let same_char = start_char + 1 in + Some ((start_line, same_char), (end_line, same_char)) + else + (* again: end_char is exclusive, so +1-1=0 *) + Some ((start_line, start_char + 1), (end_line, end_char)) + in + fprintf ppf " @[%a@]@," (print_loc ~normalizedRange) loc; + match normalizedRange with + | None -> () + | Some _ -> ( try (* let src = Ext_io.load_file file in *) (* we're putting the line break `@,` here rather than above, because this branch might not be reached (aka no inline file content display) so we don't wanna end up with two line breaks in the the consequent *) fprintf ppf "@,%s" - (Super_code_frame.print - ~is_warning:(message_kind=`warning) - ~src - ~startPos:loc.loc_start - ~endPos:loc.loc_end - ) + (Super_code_frame.print ~is_warning:(message_kind = `warning) ~src + ~startPos:loc.loc_start ~endPos:loc.loc_end) with (* this might happen if the file is e.g. "", "_none_" or any of the fake file name placeholders. we've already printed the location above, so nothing more to do here. *) - | Sys_error _ -> () - end -;; + | Sys_error _ -> + ()) -(* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L380 *) -(* This is the error report entry point. We'll replace the default reporter with this one. *) -(* let rec super_error_reporter ppf ({loc; msg; sub} : Location.error) = *) -let super_error_reporter ppf src ({loc; msg} : Location.error) = - setup_colors (); - (* open a vertical box. Everything in our message is indented 2 spaces *) - (* Format.fprintf ppf "@[@, %a@, %s@,@]" (print ~message_kind:`error "We've found a bug for you!") src loc msg; *) - Format.fprintf ppf "@[@, %a@, %s@,@]" (print ~message_kind:`error "Syntax error!" src) loc msg; + (* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L380 *) + (* This is the error report entry point. We'll replace the default reporter with this one. *) + (* let rec super_error_reporter ppf ({loc; msg; sub} : Location.error) = *) + let super_error_reporter ppf src ({loc; msg} : Location.error) = + setup_colors (); + (* open a vertical box. Everything in our message is indented 2 spaces *) + (* Format.fprintf ppf "@[@, %a@, %s@,@]" (print ~message_kind:`error "We've found a bug for you!") src loc msg; *) + Format.fprintf ppf "@[@, %a@, %s@,@]" + (print ~message_kind:`error "Syntax error!" src) + loc msg (* List.iter (Format.fprintf ppf "@,@[%a@]" super_error_reporter) sub *) -(* no need to flush here; location's report_exception (which uses this ultimately) flushes *) - + (* no need to flush here; location's report_exception (which uses this ultimately) flushes *) end diff --git a/src/res_doc.ml b/src/res_doc.ml index 63a9a731..f997f4e4 100644 --- a/src/res_doc.ml +++ b/src/res_doc.ml @@ -5,9 +5,10 @@ type mode = Break | Flat type lineStyle = | Classic (* fits? -> replace with space *) | Soft (* fits? -> replaced with nothing *) - | Hard (* always included, forces breaks in parents *) - (* always included, forces breaks in parents, but doesn't increase indentation - use case: template literals, multiline string content *) + | Hard + (* always included, forces breaks in parents *) + (* always included, forces breaks in parents, but doesn't increase indentation + use case: template literals, multiline string content *) | Literal type t = @@ -15,7 +16,8 @@ type t = | Text of string | Concat of t list | Indent of t - | IfBreaks of {yes: t; no: t; mutable broken: bool} (* when broken is true, treat as the yes branch *) + | IfBreaks of {yes: t; no: t; mutable broken: bool} + (* when broken is true, treat as the yes branch *) | LineSuffix of t | LineBreak of lineStyle | Group of {mutable shouldBreak: bool; doc: t} @@ -34,13 +36,14 @@ let rec _concat acc l = match l with | Text s1 :: Text s2 :: rest -> Text (s1 ^ s2) :: _concat acc rest | Nil :: rest -> _concat acc rest - | Concat l2 :: rest -> _concat (_concat acc rest) l2 (* notice the order here *) + | Concat l2 :: rest -> + _concat (_concat acc rest) l2 (* notice the order here *) | x :: rest -> let rest1 = _concat acc rest in if rest1 == rest then l else x :: rest1 | [] -> acc -let concat l = Concat(_concat [] l) +let concat l = Concat (_concat [] l) let indent d = Indent d let ifBreaks t f = IfBreaks {yes = t; no = f; broken = false} @@ -70,53 +73,53 @@ let trailingComma = ifBreaks comma nil let doubleQuote = Text "\"" let propagateForcedBreaks doc = - let rec walk doc = match doc with - | Text _ | Nil | LineSuffix _ -> - false - | BreakParent -> - true - | LineBreak (Hard | Literal) -> - true - | LineBreak (Classic | Soft) -> - false - | Indent children -> - let childForcesBreak = walk children in - childForcesBreak - | IfBreaks ({yes = trueDoc; no = falseDoc} as ib) -> - let falseForceBreak = walk falseDoc in - if falseForceBreak then - let _ = walk trueDoc in - ib.broken <- true; - true - else - let forceBreak = walk trueDoc in - forceBreak - | Group ({shouldBreak = forceBreak; doc = children} as gr) -> - let childForcesBreak = walk children in - let shouldBreak = forceBreak || childForcesBreak in - gr.shouldBreak <- shouldBreak; - shouldBreak - | Concat children -> - List.fold_left (fun forceBreak child -> - let childForcesBreak = walk child in - forceBreak || childForcesBreak - ) false children - | CustomLayout children -> - (* When using CustomLayout, we don't want to propagate forced breaks - * from the children up. By definition it picks the first layout that fits - * otherwise it takes the last of the list. - * However we do want to propagate forced breaks in the sublayouts. They - * might need to be broken. We just don't propagate them any higher here *) - let _ = walk (Concat children) in - false + let rec walk doc = + match doc with + | Text _ | Nil | LineSuffix _ -> false + | BreakParent -> true + | LineBreak (Hard | Literal) -> true + | LineBreak (Classic | Soft) -> false + | Indent children -> + let childForcesBreak = walk children in + childForcesBreak + | IfBreaks ({yes = trueDoc; no = falseDoc} as ib) -> + let falseForceBreak = walk falseDoc in + if falseForceBreak then ( + let _ = walk trueDoc in + ib.broken <- true; + true) + else + let forceBreak = walk trueDoc in + forceBreak + | Group ({shouldBreak = forceBreak; doc = children} as gr) -> + let childForcesBreak = walk children in + let shouldBreak = forceBreak || childForcesBreak in + gr.shouldBreak <- shouldBreak; + shouldBreak + | Concat children -> + List.fold_left + (fun forceBreak child -> + let childForcesBreak = walk child in + forceBreak || childForcesBreak) + false children + | CustomLayout children -> + (* When using CustomLayout, we don't want to propagate forced breaks + * from the children up. By definition it picks the first layout that fits + * otherwise it takes the last of the list. + * However we do want to propagate forced breaks in the sublayouts. They + * might need to be broken. We just don't propagate them any higher here *) + let _ = walk (Concat children) in + false in let _ = walk doc in () (* See documentation in interface file *) -let rec willBreak doc = match doc with - | LineBreak (Hard | Literal) | BreakParent | Group {shouldBreak = true} -> true - | Group {doc} | Indent doc | CustomLayout (doc::_) -> willBreak doc +let rec willBreak doc = + match doc with + | LineBreak (Hard | Literal) | BreakParent | Group {shouldBreak = true} -> + true + | Group {doc} | Indent doc | CustomLayout (doc :: _) -> willBreak doc | Concat docs -> List.exists willBreak docs | IfBreaks {yes; no} -> willBreak yes || willBreak no | _ -> false @@ -125,53 +128,50 @@ let join ~sep docs = let rec loop acc sep docs = match docs with | [] -> List.rev acc - | [x] -> List.rev (x::acc) - | x::xs -> loop (sep::x::acc) sep xs + | [x] -> List.rev (x :: acc) + | x :: xs -> loop (sep :: x :: acc) sep xs in - concat(loop [] sep docs) + concat (loop [] sep docs) let fits w stack = let width = ref w in let result = ref None in let rec calculate indent mode doc = - match mode, doc with + match (mode, doc) with | _ when result.contents != None -> () | _ when width.contents < 0 -> result := Some false - | _, Nil - | _, LineSuffix _ - | _, BreakParent -> () - | _, Text txt -> width := width.contents - (String.length txt) + | _, Nil | _, LineSuffix _ | _, BreakParent -> () + | _, Text txt -> width := width.contents - String.length txt | _, Indent doc -> calculate (indent + 2) mode doc - | Flat, LineBreak Hard - | Flat, LineBreak Literal -> result := Some true + | Flat, LineBreak Hard | Flat, LineBreak Literal -> result := Some true | Flat, LineBreak Classic -> width := width.contents - 1 | Flat, LineBreak Soft -> () | Break, LineBreak _ -> result := Some true | _, Group {shouldBreak = true; doc} -> calculate indent Break doc | _, Group {doc} -> calculate indent mode doc - | _, IfBreaks {yes = breakDoc; broken = true} -> calculate indent mode breakDoc + | _, IfBreaks {yes = breakDoc; broken = true} -> + calculate indent mode breakDoc | Break, IfBreaks {yes = breakDoc} -> calculate indent mode breakDoc | Flat, IfBreaks {no = flatDoc} -> calculate indent mode flatDoc | _, Concat docs -> calculateConcat indent mode docs - | _, CustomLayout (hd::_) -> + | _, CustomLayout (hd :: _) -> (* TODO: if we have nested custom layouts, what we should do here? *) - calculate indent mode hd + calculate indent mode hd | _, CustomLayout [] -> () and calculateConcat indent mode docs = - if result.contents == None then ( + if result.contents == None then match docs with | [] -> () - | doc::rest -> + | doc :: rest -> calculate indent mode doc; calculateConcat indent mode rest - ) in let rec calculateAll stack = - match result.contents, stack with + match (result.contents, stack) with | Some r, _ -> r | None, [] -> !width >= 0 - | None, (indent, mode, doc)::rest -> + | None, (indent, mode, doc) :: rest -> calculate indent mode doc; calculateAll rest in @@ -183,151 +183,136 @@ let toString ~width doc = let rec process ~pos lineSuffices stack = match stack with - | ((ind, mode, doc) as cmd)::rest -> - begin match doc with - | Nil | BreakParent -> - process ~pos lineSuffices rest + | ((ind, mode, doc) as cmd) :: rest -> ( + match doc with + | Nil | BreakParent -> process ~pos lineSuffices rest | Text txt -> MiniBuffer.add_string buffer txt; process ~pos:(String.length txt + pos) lineSuffices rest - | LineSuffix doc -> - process ~pos ((ind, mode, doc)::lineSuffices) rest + | LineSuffix doc -> process ~pos ((ind, mode, doc) :: lineSuffices) rest | Concat docs -> let ops = List.map (fun doc -> (ind, mode, doc)) docs in process ~pos lineSuffices (List.append ops rest) - | Indent doc -> - process ~pos lineSuffices ((ind + 2, mode, doc)::rest) + | Indent doc -> process ~pos lineSuffices ((ind + 2, mode, doc) :: rest) | IfBreaks {yes = breakDoc; broken = true} -> - process ~pos lineSuffices ((ind, mode, breakDoc)::rest) + process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) | IfBreaks {yes = breakDoc; no = flatDoc} -> if mode = Break then - process ~pos lineSuffices ((ind, mode, breakDoc)::rest) - else - process ~pos lineSuffices ((ind, mode, flatDoc)::rest) - | LineBreak lineStyle -> - if mode = Break then ( - begin match lineSuffices with + process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) + else process ~pos lineSuffices ((ind, mode, flatDoc) :: rest) + | LineBreak lineStyle -> + if mode = Break then + match lineSuffices with | [] -> if lineStyle = Literal then ( MiniBuffer.add_char buffer '\n'; - process ~pos:0 [] rest - ) else ( + process ~pos:0 [] rest) + else ( MiniBuffer.flush_newline buffer; MiniBuffer.add_string buffer (String.make ind ' ' [@doesNotRaise]); - process ~pos:ind [] rest - ) + process ~pos:ind [] rest) | _docs -> - process ~pos:ind [] (List.concat [List.rev lineSuffices; cmd::rest]) - end - ) else (* mode = Flat *) ( - let pos = match lineStyle with - | Classic -> MiniBuffer.add_string buffer " "; pos + 1 - | Hard -> MiniBuffer.flush_newline buffer; 0 - | Literal -> MiniBuffer.add_char buffer '\n'; 0 - | Soft -> pos + process ~pos:ind [] + (List.concat [List.rev lineSuffices; cmd :: rest]) + else + (* mode = Flat *) + let pos = + match lineStyle with + | Classic -> + MiniBuffer.add_string buffer " "; + pos + 1 + | Hard -> + MiniBuffer.flush_newline buffer; + 0 + | Literal -> + MiniBuffer.add_char buffer '\n'; + 0 + | Soft -> pos in process ~pos lineSuffices rest - ) | Group {shouldBreak; doc} -> - if shouldBreak || not (fits (width - pos) ((ind, Flat, doc)::rest)) then - process ~pos lineSuffices ((ind, Break, doc)::rest) - else - process ~pos lineSuffices ((ind, Flat, doc)::rest) + if shouldBreak || not (fits (width - pos) ((ind, Flat, doc) :: rest)) + then process ~pos lineSuffices ((ind, Break, doc) :: rest) + else process ~pos lineSuffices ((ind, Flat, doc) :: rest) | CustomLayout docs -> - let rec findGroupThatFits groups = match groups with - | [] -> Nil - | [lastGroup] -> lastGroup - | doc::docs -> - if (fits (width - pos) ((ind, Flat, doc)::rest)) then - doc - else - findGroupThatFits docs + let rec findGroupThatFits groups = + match groups with + | [] -> Nil + | [lastGroup] -> lastGroup + | doc :: docs -> + if fits (width - pos) ((ind, Flat, doc) :: rest) then doc + else findGroupThatFits docs in let doc = findGroupThatFits docs in - process ~pos lineSuffices ((ind, Flat, doc)::rest) - end - | [] -> - begin match lineSuffices with + process ~pos lineSuffices ((ind, Flat, doc) :: rest)) + | [] -> ( + match lineSuffices with | [] -> () - | suffices -> - process ~pos:0 [] (List.rev suffices) - end + | suffices -> process ~pos:0 [] (List.rev suffices)) in process ~pos:0 [] [(0, Flat, doc)]; MiniBuffer.contents buffer - let debug t = let rec toDoc = function | Nil -> text "nil" | BreakParent -> text "breakparent" | Text txt -> text ("text(\"" ^ txt ^ "\")") - | LineSuffix doc -> group( - concat [ - text "linesuffix("; - indent ( - concat [line; toDoc doc] - ); - line; - text ")" - ] - ) + | LineSuffix doc -> + group + (concat + [ + text "linesuffix("; + indent (concat [line; toDoc doc]); + line; + text ")"; + ]) | Concat [] -> text "concat()" - | Concat docs -> group( - concat [ - text "concat("; - indent ( - concat [ - line; - join ~sep:(concat [text ","; line]) - (List.map toDoc docs) ; - ] - ); - line; - text ")" - ] - ) - | CustomLayout docs -> group( - concat [ - text "customLayout("; - indent ( - concat [ - line; - join ~sep:(concat [text ","; line]) - (List.map toDoc docs) ; - ] - ); - line; - text ")" - ] - ) + | Concat docs -> + group + (concat + [ + text "concat("; + indent + (concat + [ + line; + join ~sep:(concat [text ","; line]) (List.map toDoc docs); + ]); + line; + text ")"; + ]) + | CustomLayout docs -> + group + (concat + [ + text "customLayout("; + indent + (concat + [ + line; + join ~sep:(concat [text ","; line]) (List.map toDoc docs); + ]); + line; + text ")"; + ]) | Indent doc -> - concat [ - text "indent("; - softLine; - toDoc doc; - softLine; - text ")"; - ] + concat [text "indent("; softLine; toDoc doc; softLine; text ")"] | IfBreaks {yes = trueDoc; broken = true} -> toDoc trueDoc | IfBreaks {yes = trueDoc; no = falseDoc} -> - group( - concat [ - text "ifBreaks("; - indent ( - concat [ - line; - toDoc trueDoc; - concat [text ","; line]; - toDoc falseDoc; - ] - ); - line; - text ")" - ] - ) + group + (concat + [ + text "ifBreaks("; + indent + (concat + [line; toDoc trueDoc; concat [text ","; line]; toDoc falseDoc]); + line; + text ")"; + ]) | LineBreak break -> - let breakTxt = match break with + let breakTxt = + match break with | Classic -> "Classic" | Soft -> "Soft" | Hard -> "Hard" @@ -335,21 +320,21 @@ let debug t = in text ("LineBreak(" ^ breakTxt ^ ")") | Group {shouldBreak; doc} -> - group( - concat [ - text "Group("; - indent ( - concat [ - line; - text ("{shouldBreak: " ^ (string_of_bool shouldBreak) ^ "}"); - concat [text ","; line]; - toDoc doc; - ] - ); - line; - text ")" - ] - ) + group + (concat + [ + text "Group("; + indent + (concat + [ + line; + text ("{shouldBreak: " ^ string_of_bool shouldBreak ^ "}"); + concat [text ","; line]; + toDoc doc; + ]); + line; + text ")"; + ]) in let doc = toDoc t in toString ~width:10 doc |> print_endline diff --git a/src/res_doc.mli b/src/res_doc.mli index 031afbaf..cfb79fe3 100644 --- a/src/res_doc.mli +++ b/src/res_doc.mli @@ -1,42 +1,43 @@ type t -val nil: t -val line: t -val hardLine: t -val softLine: t -val literalLine: t -val text: string -> t -val concat: t list -> t -val indent: t -> t -val ifBreaks: t -> t -> t -val lineSuffix: t -> t -val group: t -> t -val breakableGroup: forceBreak : bool -> t -> t +val nil : t +val line : t +val hardLine : t +val softLine : t +val literalLine : t +val text : string -> t +val concat : t list -> t +val indent : t -> t +val ifBreaks : t -> t -> t +val lineSuffix : t -> t +val group : t -> t +val breakableGroup : forceBreak:bool -> t -> t + (* `customLayout docs` will pick the layout that fits from `docs`. * This is a very expensive computation as every layout from the list * will be checked until one fits. *) -val customLayout: t list -> t -val breakParent: t -val join: sep: t -> t list -> t +val customLayout : t list -> t +val breakParent : t +val join : sep:t -> t list -> t -val space: t -val comma: t -val dot: t -val dotdot: t -val dotdotdot: t -val lessThan: t -val greaterThan: t -val lbrace: t -val rbrace: t -val lparen: t -val rparen: t -val lbracket: t -val rbracket: t -val question: t -val tilde: t -val equal: t -val trailingComma: t -val doubleQuote: t [@@live] +val space : t +val comma : t +val dot : t +val dotdot : t +val dotdotdot : t +val lessThan : t +val greaterThan : t +val lbrace : t +val rbrace : t +val lparen : t +val rparen : t +val lbracket : t +val rbracket : t +val question : t +val tilde : t +val equal : t +val trailingComma : t +val doubleQuote : t [@@live] (* * `willBreak doc` checks whether `doc` contains forced line breaks. @@ -57,7 +58,7 @@ val doubleQuote: t [@@live] * The consumer can then manually insert a `breakParent` doc, to manually propagate the * force breaks from bottom to top. *) -val willBreak: t -> bool +val willBreak : t -> bool -val toString: width: int -> t -> string -val debug: t -> unit [@@live] +val toString : width:int -> t -> string +val debug : t -> unit [@@live] diff --git a/src/res_driver.ml b/src/res_driver.ml index d827880a..f30a071c 100644 --- a/src/res_driver.ml +++ b/src/res_driver.ml @@ -6,104 +6,111 @@ type ('ast, 'diagnostics) parseResult = { parsetree: 'ast; diagnostics: 'diagnostics; invalid: bool; - comments: Res_comment.t list + comments: Res_comment.t list; } -type ('diagnostics) parsingEngine = { +type 'diagnostics parsingEngine = { parseImplementation: - forPrinter:bool -> filename:string - -> (Parsetree.structure, 'diagnostics) parseResult; + forPrinter:bool -> + filename:string -> + (Parsetree.structure, 'diagnostics) parseResult; parseInterface: - forPrinter:bool -> filename:string - -> (Parsetree.signature, 'diagnostics) parseResult; - stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit + forPrinter:bool -> + filename:string -> + (Parsetree.signature, 'diagnostics) parseResult; + stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit; } type printEngine = { printImplementation: - width: int - -> filename: string - -> comments: Res_comment.t list - -> Parsetree.structure - -> unit; + width:int -> + filename:string -> + comments:Res_comment.t list -> + Parsetree.structure -> + unit; printInterface: - width: int - -> filename: string - -> comments: Res_comment.t list - -> Parsetree.signature - -> unit; + width:int -> + filename:string -> + comments:Res_comment.t list -> + Parsetree.signature -> + unit; } let setup ~filename ~forPrinter () = let src = IO.readFile ~filename in - let mode = if forPrinter then Res_parser.Default - else ParseForTypeChecker - in + let mode = if forPrinter then Res_parser.Default else ParseForTypeChecker in Res_parser.make ~mode src filename -let parsingEngine = { - parseImplementation = begin fun ~forPrinter ~filename -> - let engine = setup ~filename ~forPrinter () in - let structure = Res_core.parseImplementation engine in - let (invalid, diagnostics) = match engine.diagnostics with - | [] as diagnostics -> (false, diagnostics) - | _ as diagnostics -> (true, diagnostics) - in { - filename = engine.scanner.filename; - source = engine.scanner.src; - parsetree = structure; - diagnostics; - invalid; - comments = List.rev engine.comments; - } - end; - parseInterface = begin fun ~forPrinter ~filename -> - let engine = setup ~filename ~forPrinter () in - let signature = Res_core.parseSpecification engine in - let (invalid, diagnostics) = match engine.diagnostics with - | [] as diagnostics -> (false, diagnostics) - | _ as diagnostics -> (true, diagnostics) - in { - filename = engine.scanner.filename; - source = engine.scanner.src; - parsetree = signature; - diagnostics; - invalid; - comments = List.rev engine.comments; - } - end; - stringOfDiagnostics = begin fun ~source ~filename:_ diagnostics -> - Res_diagnostics.printReport diagnostics source - end; -} +let parsingEngine = + { + parseImplementation = + (fun ~forPrinter ~filename -> + let engine = setup ~filename ~forPrinter () in + let structure = Res_core.parseImplementation engine in + let invalid, diagnostics = + match engine.diagnostics with + | [] as diagnostics -> (false, diagnostics) + | _ as diagnostics -> (true, diagnostics) + in + { + filename = engine.scanner.filename; + source = engine.scanner.src; + parsetree = structure; + diagnostics; + invalid; + comments = List.rev engine.comments; + }); + parseInterface = + (fun ~forPrinter ~filename -> + let engine = setup ~filename ~forPrinter () in + let signature = Res_core.parseSpecification engine in + let invalid, diagnostics = + match engine.diagnostics with + | [] as diagnostics -> (false, diagnostics) + | _ as diagnostics -> (true, diagnostics) + in + { + filename = engine.scanner.filename; + source = engine.scanner.src; + parsetree = signature; + diagnostics; + invalid; + comments = List.rev engine.comments; + }); + stringOfDiagnostics = + (fun ~source ~filename:_ diagnostics -> + Res_diagnostics.printReport diagnostics source); + } -let printEngine = { - printImplementation = begin fun ~width ~filename:_ ~comments structure -> - print_string (Res_printer.printImplementation ~width structure ~comments) - end; - printInterface = begin fun ~width ~filename:_ ~comments signature -> - print_string (Res_printer.printInterface ~width signature ~comments) - end; -} +let printEngine = + { + printImplementation = + (fun ~width ~filename:_ ~comments structure -> + print_string + (Res_printer.printImplementation ~width structure ~comments)); + printInterface = + (fun ~width ~filename:_ ~comments signature -> + print_string (Res_printer.printInterface ~width signature ~comments)); + } let parse_implementation sourcefile = Location.input_name := sourcefile; let parseResult = parsingEngine.parseImplementation ~forPrinter:false ~filename:sourcefile in - if parseResult.invalid then begin + if parseResult.invalid then ( Res_diagnostics.printReport parseResult.diagnostics parseResult.source; - exit 1 - end; + exit 1); parseResult.parsetree -[@@raises exit] + [@@raises exit] let parse_interface sourcefile = Location.input_name := sourcefile; - let parseResult = parsingEngine.parseInterface ~forPrinter:false ~filename:sourcefile in - if parseResult.invalid then begin + let parseResult = + parsingEngine.parseInterface ~forPrinter:false ~filename:sourcefile + in + if parseResult.invalid then ( Res_diagnostics.printReport parseResult.diagnostics parseResult.source; - exit 1 - end; + exit 1); parseResult.parsetree -[@@raises exit] + [@@raises exit] diff --git a/src/res_driver.mli b/src/res_driver.mli index 0facc0a5..9ea21e37 100644 --- a/src/res_driver.mli +++ b/src/res_driver.mli @@ -4,46 +4,44 @@ type ('ast, 'diagnostics) parseResult = { parsetree: 'ast; diagnostics: 'diagnostics; invalid: bool; - comments: Res_comment.t list + comments: Res_comment.t list; } -type ('diagnostics) parsingEngine = { +type 'diagnostics parsingEngine = { parseImplementation: - forPrinter:bool -> filename:string - -> (Parsetree.structure, 'diagnostics) parseResult; + forPrinter:bool -> + filename:string -> + (Parsetree.structure, 'diagnostics) parseResult; parseInterface: - forPrinter:bool -> filename:string - -> (Parsetree.signature, 'diagnostics) parseResult; - stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit + forPrinter:bool -> + filename:string -> + (Parsetree.signature, 'diagnostics) parseResult; + stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit; } type printEngine = { printImplementation: - width: int - -> filename: string - -> comments: Res_comment.t list - -> Parsetree.structure - -> unit; + width:int -> + filename:string -> + comments:Res_comment.t list -> + Parsetree.structure -> + unit; printInterface: - width: int - -> filename: string - -> comments: Res_comment.t list - -> Parsetree.signature - -> unit; + width:int -> + filename:string -> + comments:Res_comment.t list -> + Parsetree.signature -> + unit; } -val parsingEngine: (Res_diagnostics.t list) parsingEngine +val parsingEngine : Res_diagnostics.t list parsingEngine -val printEngine: printEngine +val printEngine : printEngine (* ReScript implementation parsing compatible with ocaml pparse driver. Used by the compiler. *) -val parse_implementation: - string -> Parsetree.structure -[@@live] -[@@raises Location.Error] +val parse_implementation : string -> Parsetree.structure + [@@live] [@@raises Location.Error] (* ReScript interface parsing compatible with ocaml pparse driver. Used by the compiler *) -val parse_interface: - string -> Parsetree.signature -[@@live] -[@@raises Location.Error] +val parse_interface : string -> Parsetree.signature + [@@live] [@@raises Location.Error] diff --git a/src/res_driver_binary.ml b/src/res_driver_binary.ml index 40851557..58a81536 100644 --- a/src/res_driver_binary.ml +++ b/src/res_driver_binary.ml @@ -1,12 +1,14 @@ -let printEngine = Res_driver.{ - printImplementation = begin fun ~width:_ ~filename ~comments:_ structure -> - output_string stdout Config.ast_impl_magic_number; - output_value stdout filename; - output_value stdout structure - end; - printInterface = begin fun ~width:_ ~filename ~comments:_ signature -> - output_string stdout Config.ast_intf_magic_number; - output_value stdout filename; - output_value stdout signature - end; -} +let printEngine = + Res_driver. + { + printImplementation = + (fun ~width:_ ~filename ~comments:_ structure -> + output_string stdout Config.ast_impl_magic_number; + output_value stdout filename; + output_value stdout structure); + printInterface = + (fun ~width:_ ~filename ~comments:_ signature -> + output_string stdout Config.ast_intf_magic_number; + output_value stdout filename; + output_value stdout signature); + } diff --git a/src/res_driver_ml_parser.ml b/src/res_driver_ml_parser.ml index 221a31c5..0d6a99e9 100644 --- a/src/res_driver_ml_parser.ml +++ b/src/res_driver_ml_parser.ml @@ -4,15 +4,14 @@ module IO = Res_io let setup ~filename = if String.length filename > 0 then ( Location.input_name := filename; - IO.readFile ~filename |> Lexing.from_string - ) else - Lexing.from_channel stdin + IO.readFile ~filename |> Lexing.from_string) + else Lexing.from_channel stdin let extractOcamlConcreteSyntax filename = - let lexbuf = if String.length filename > 0 then - IO.readFile ~filename |> Lexing.from_string - else - Lexing.from_channel stdin + let lexbuf = + if String.length filename > 0 then + IO.readFile ~filename |> Lexing.from_string + else Lexing.from_channel stdin in let stringLocs = ref [] in let commentData = ref [] in @@ -20,25 +19,25 @@ let extractOcamlConcreteSyntax filename = let token = Lexer.token_with_comments lexbuf in match token with | OcamlParser.COMMENT (txt, loc) -> - let comment = Res_comment.fromOcamlComment - ~loc - ~prevTokEndPos - ~txt - in - commentData := comment::(!commentData); + let comment = Res_comment.fromOcamlComment ~loc ~prevTokEndPos ~txt in + commentData := comment :: !commentData; next loc.Location.loc_end () | OcamlParser.STRING (_txt, None) -> let open Location in - let loc = { - loc_start = lexbuf.lex_start_p; - loc_end = lexbuf.Lexing.lex_curr_p; - loc_ghost = false; - } in + let loc = + { + loc_start = lexbuf.lex_start_p; + loc_end = lexbuf.Lexing.lex_curr_p; + loc_ghost = false; + } + in let len = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum in - let txt = Bytes.to_string ( - (Bytes.sub [@doesNotRaise]) lexbuf.Lexing.lex_buffer loc.loc_start.pos_cnum len - ) in - stringLocs := (txt, loc)::(!stringLocs); + let txt = + Bytes.to_string + ((Bytes.sub [@doesNotRaise]) lexbuf.Lexing.lex_buffer + loc.loc_start.pos_cnum len) + in + stringLocs := (txt, loc) :: !stringLocs; next lexbuf.Lexing.lex_curr_p () | OcamlParser.EOF -> () | _ -> next lexbuf.Lexing.lex_curr_p () @@ -46,47 +45,56 @@ let extractOcamlConcreteSyntax filename = next lexbuf.Lexing.lex_start_p (); (List.rev !stringLocs, List.rev !commentData) -let parsingEngine = { - Res_driver.parseImplementation = begin fun ~forPrinter:_ ~filename -> - let lexbuf = setup ~filename in - let (stringData, comments) = extractOcamlConcreteSyntax !Location.input_name in - let structure = - Parse.implementation lexbuf - |> Res_ast_conversion.replaceStringLiteralStructure stringData - |> Res_ast_conversion.structure - in { - filename = !Location.input_name; - source = Bytes.to_string lexbuf.lex_buffer; - parsetree = structure; - diagnostics = (); - invalid = false; - comments = comments; - } - end; - parseInterface = begin fun ~forPrinter:_ ~filename -> - let lexbuf = setup ~filename in - let (stringData, comments) = extractOcamlConcreteSyntax !Location.input_name in - let signature = - Parse.interface lexbuf - |> Res_ast_conversion.replaceStringLiteralSignature stringData - |> Res_ast_conversion.signature - in { - filename = !Location.input_name; - source = Bytes.to_string lexbuf.lex_buffer; - parsetree = signature; - diagnostics = (); - invalid = false; - comments = comments; - } - end; - stringOfDiagnostics = begin fun ~source:_ ~filename:_ _diagnostics -> () end; -} +let parsingEngine = + { + Res_driver.parseImplementation = + (fun ~forPrinter:_ ~filename -> + let lexbuf = setup ~filename in + let stringData, comments = + extractOcamlConcreteSyntax !Location.input_name + in + let structure = + Parse.implementation lexbuf + |> Res_ast_conversion.replaceStringLiteralStructure stringData + |> Res_ast_conversion.structure + in + { + filename = !Location.input_name; + source = Bytes.to_string lexbuf.lex_buffer; + parsetree = structure; + diagnostics = (); + invalid = false; + comments; + }); + parseInterface = + (fun ~forPrinter:_ ~filename -> + let lexbuf = setup ~filename in + let stringData, comments = + extractOcamlConcreteSyntax !Location.input_name + in + let signature = + Parse.interface lexbuf + |> Res_ast_conversion.replaceStringLiteralSignature stringData + |> Res_ast_conversion.signature + in + { + filename = !Location.input_name; + source = Bytes.to_string lexbuf.lex_buffer; + parsetree = signature; + diagnostics = (); + invalid = false; + comments; + }); + stringOfDiagnostics = (fun ~source:_ ~filename:_ _diagnostics -> ()); + } -let printEngine = Res_driver.{ - printImplementation = begin fun ~width:_ ~filename:_ ~comments:_ structure -> - Pprintast.structure Format.std_formatter structure - end; - printInterface = begin fun ~width:_ ~filename:_ ~comments:_ signature -> - Pprintast.signature Format.std_formatter signature - end; -} +let printEngine = + Res_driver. + { + printImplementation = + (fun ~width:_ ~filename:_ ~comments:_ structure -> + Pprintast.structure Format.std_formatter structure); + printInterface = + (fun ~width:_ ~filename:_ ~comments:_ signature -> + Pprintast.signature Format.std_formatter signature); + } diff --git a/src/res_driver_ml_parser.mli b/src/res_driver_ml_parser.mli index 4743e229..63ea8f81 100644 --- a/src/res_driver_ml_parser.mli +++ b/src/res_driver_ml_parser.mli @@ -2,7 +2,8 @@ (* extracts comments and the original string data from an ocaml file *) val extractOcamlConcreteSyntax : - string -> (string * Location.t) list * Res_comment.t list [@@live] + string -> (string * Location.t) list * Res_comment.t list + [@@live] val parsingEngine : unit Res_driver.parsingEngine diff --git a/src/res_driver_reason_binary.ml b/src/res_driver_reason_binary.ml index ad1beac7..0882a39b 100644 --- a/src/res_driver_reason_binary.ml +++ b/src/res_driver_reason_binary.ml @@ -1,11 +1,15 @@ module IO = Res_io -let isReasonDocComment (comment: Res_comment.t) = +let isReasonDocComment (comment : Res_comment.t) = let content = Res_comment.txt comment in let len = String.length content in if len = 0 then true - else if len >= 2 && (String.unsafe_get content 0 = '*' && String.unsafe_get content 1 = '*') then false - else if len >= 1 && (String.unsafe_get content 0 = '*') then true + else if + len >= 2 + && String.unsafe_get content 0 = '*' + && String.unsafe_get content 1 = '*' + then false + else if len >= 1 && String.unsafe_get content 0 = '*' then true else false let extractConcreteSyntax filename = @@ -15,26 +19,27 @@ let extractConcreteSyntax filename = let scanner = Res_scanner.make src ~filename in let rec next prevEndPos scanner = - let (startPos, endPos, token) = Res_scanner.scan scanner in + let startPos, endPos, token = Res_scanner.scan scanner in match token with | Eof -> () | Comment c -> Res_comment.setPrevTokEndPos c prevEndPos; - commentData := c::(!commentData); + commentData := c :: !commentData; next endPos scanner | String _ -> - let loc = {Location.loc_start = startPos; loc_end = endPos; loc_ghost = false} in + let loc = + {Location.loc_start = startPos; loc_end = endPos; loc_ghost = false} + in let len = endPos.pos_cnum - startPos.pos_cnum in let txt = (String.sub [@doesNotRaise]) src startPos.pos_cnum len in - stringData := (txt, loc)::(!stringData); - next endPos scanner; + stringData := (txt, loc) :: !stringData; + next endPos scanner | Lbrace -> (* handle {| |} or {sql||sql} quoted strings. We don't care about its contents. Why? // abcdef inside the quoted string would otherwise be picked up as an extra comment *) Res_scanner.tryAdvanceQuotedString scanner; next endPos scanner - | _ -> - next endPos scanner + | _ -> next endPos scanner in next Lexing.dummy_pos scanner; let comments = @@ -44,60 +49,71 @@ let extractConcreteSyntax filename = in (comments, !stringData) -let parsingEngine = { - Res_driver.parseImplementation = begin fun ~forPrinter:_ ~filename -> - let (chan, close) = if (String.length filename) == 0 then - (stdin, fun _ -> ()) - else - let file_chan = open_in_bin filename in - let () = seek_in file_chan 0 in - file_chan, close_in_noerr - in - let magic = Config.ast_impl_magic_number in - ignore ((really_input_string [@doesNotRaise]) chan (String.length magic)); - let filename = input_value chan in - let (comments, stringData) = if filename <> "" then extractConcreteSyntax filename else ([], []) in - let ast = input_value chan in - close chan; - let structure = ast - |> Res_ast_conversion.replaceStringLiteralStructure stringData - |> Res_ast_conversion.normalizeReasonArityStructure ~forPrinter:true - |> Res_ast_conversion.structure - in { - Res_driver.filename = filename; - source = ""; - parsetree = structure; - diagnostics = (); - invalid = false; - comments = comments; - } - end; - parseInterface = begin fun ~forPrinter:_ ~filename -> - let (chan, close) = if String.length filename == 0 then - (stdin, fun _ -> ()) - else - let file_chan = open_in_bin filename in - let () = seek_in file_chan 0 in - file_chan, close_in_noerr - in - let magic = Config.ast_intf_magic_number in - ignore ((really_input_string [@doesNotRaise]) chan (String.length magic)); - let filename = input_value chan in - let (comments, stringData) = if filename <> "" then extractConcreteSyntax filename else ([], []) in - let ast = input_value chan in - close chan; - let signature = ast - |> Res_ast_conversion.replaceStringLiteralSignature stringData - |> Res_ast_conversion.normalizeReasonAritySignature ~forPrinter:true - |> Res_ast_conversion.signature - in { - Res_driver.filename; - source = ""; - parsetree = signature; - diagnostics = (); - invalid = false; - comments = comments; - } - end; - stringOfDiagnostics = begin fun ~source:_ ~filename:_ _diagnostics -> () end; -} +let parsingEngine = + { + Res_driver.parseImplementation = + (fun ~forPrinter:_ ~filename -> + let chan, close = + if String.length filename == 0 then (stdin, fun _ -> ()) + else + let file_chan = open_in_bin filename in + let () = seek_in file_chan 0 in + (file_chan, close_in_noerr) + in + let magic = Config.ast_impl_magic_number in + ignore + ((really_input_string [@doesNotRaise]) chan (String.length magic)); + let filename = input_value chan in + let comments, stringData = + if filename <> "" then extractConcreteSyntax filename else ([], []) + in + let ast = input_value chan in + close chan; + let structure = + ast + |> Res_ast_conversion.replaceStringLiteralStructure stringData + |> Res_ast_conversion.normalizeReasonArityStructure ~forPrinter:true + |> Res_ast_conversion.structure + in + { + Res_driver.filename; + source = ""; + parsetree = structure; + diagnostics = (); + invalid = false; + comments; + }); + parseInterface = + (fun ~forPrinter:_ ~filename -> + let chan, close = + if String.length filename == 0 then (stdin, fun _ -> ()) + else + let file_chan = open_in_bin filename in + let () = seek_in file_chan 0 in + (file_chan, close_in_noerr) + in + let magic = Config.ast_intf_magic_number in + ignore + ((really_input_string [@doesNotRaise]) chan (String.length magic)); + let filename = input_value chan in + let comments, stringData = + if filename <> "" then extractConcreteSyntax filename else ([], []) + in + let ast = input_value chan in + close chan; + let signature = + ast + |> Res_ast_conversion.replaceStringLiteralSignature stringData + |> Res_ast_conversion.normalizeReasonAritySignature ~forPrinter:true + |> Res_ast_conversion.signature + in + { + Res_driver.filename; + source = ""; + parsetree = signature; + diagnostics = (); + invalid = false; + comments; + }); + stringOfDiagnostics = (fun ~source:_ ~filename:_ _diagnostics -> ()); + } diff --git a/src/res_grammar.ml b/src/res_grammar.ml index 061c17a4..e2d982df 100644 --- a/src/res_grammar.ml +++ b/src/res_grammar.ml @@ -19,7 +19,9 @@ type t = | ExprArrayMutation | ExprIf | ExprFor - | IfCondition | IfBranch | ElseBranch + | IfCondition + | IfBranch + | ElseBranch | TypeExpression | External | PatternMatching @@ -28,7 +30,6 @@ type t = | PatternList | PatternOcamlList | PatternRecord - | TypeDef | TypeConstrName | TypeParams @@ -69,7 +70,8 @@ let toString = function | JsxAttribute -> "a jsx attribute" | ExprOperand -> "a basic expression" | ExprUnary -> "a unary expression" - | ExprBinaryAfterOp op -> "an expression after the operator \"" ^ Token.toString op ^ "\"" + | ExprBinaryAfterOp op -> + "an expression after the operator \"" ^ Token.toString op ^ "\"" | ExprIf -> "an if expression" | IfCondition -> "the condition of an if expression" | IfBranch -> "the true-branch of an if expression" @@ -122,59 +124,37 @@ let toString = function | TagNames -> "tag names" let isSignatureItemStart = function - | Token.At - | Let - | Typ - | External - | Exception - | Open - | Include - | Module - | AtAt - | Export - | PercentPercent -> true + | Token.At | Let | Typ | External | Exception | Open | Include | Module | AtAt + | Export | PercentPercent -> + true | _ -> false let isAtomicPatternStart = function - | Token.Int _ | String _ | Codepoint _ | Backtick - | Lparen | Lbracket | Lbrace - | Underscore - | Lident _ | Uident _ | List - | Exception | Lazy - | Percent -> true + | Token.Int _ | String _ | Codepoint _ | Backtick | Lparen | Lbracket | Lbrace + | Underscore | Lident _ | Uident _ | List | Exception | Lazy | Percent -> + true | _ -> false let isAtomicExprStart = function - | Token.True | False - | Int _ | String _ | Float _ | Codepoint _ - | Backtick - | Uident _ | Lident _ | Hash - | Lparen - | List - | Lbracket - | Lbrace - | LessThan - | Module - | Percent -> true + | Token.True | False | Int _ | String _ | Float _ | Codepoint _ | Backtick + | Uident _ | Lident _ | Hash | Lparen | List | Lbracket | Lbrace | LessThan + | Module | Percent -> + true | _ -> false let isAtomicTypExprStart = function - | Token.SingleQuote | Underscore - | Lparen | Lbrace - | Uident _ | Lident _ - | Percent -> true + | Token.SingleQuote | Underscore | Lparen | Lbrace | Uident _ | Lident _ + | Percent -> + true | _ -> false let isExprStart = function - | Token.True | False - | Int _ | String _ | Float _ | Codepoint _ | Backtick + | Token.True | False | Int _ | String _ | Float _ | Codepoint _ | Backtick | Underscore (* _ => doThings() *) - | Uident _ | Lident _ | Hash - | Lparen | List | Module | Lbracket | Lbrace - | LessThan - | Minus | MinusDot | Plus | PlusDot | Bang - | Percent | At - | If | Switch | While | For | Assert | Lazy | Try -> true + | Uident _ | Lident _ | Hash | Lparen | List | Module | Lbracket | Lbrace + | LessThan | Minus | MinusDot | Plus | PlusDot | Bang | Percent | At | If + | Switch | While | For | Assert | Lazy | Try -> + true | _ -> false let isJsxAttributeStart = function @@ -182,26 +162,17 @@ let isJsxAttributeStart = function | _ -> false let isStructureItemStart = function - | Token.Open - | Let - | Typ - | External | Import | Export - | Exception - | Include - | Module - | AtAt - | PercentPercent - | At -> true + | Token.Open | Let | Typ | External | Import | Export | Exception | Include + | Module | AtAt | PercentPercent | At -> + true | t when isExprStart t -> true | _ -> false let isPatternStart = function - | Token.Int _ | Float _ | String _ | Codepoint _ | Backtick | True | False | Minus | Plus - | Lparen | Lbracket | Lbrace | List - | Underscore - | Lident _ | Uident _ | Hash - | Exception | Lazy | Percent | Module - | At -> true + | Token.Int _ | Float _ | String _ | Codepoint _ | Backtick | True | False + | Minus | Plus | Lparen | Lbracket | Lbrace | List | Underscore | Lident _ + | Uident _ | Hash | Exception | Lazy | Percent | Module | At -> + true | _ -> false let isParameterStart = function @@ -216,27 +187,20 @@ let isStringFieldDeclStart = function (* TODO: overparse Uident ? *) let isFieldDeclStart = function - | Token.At | Mutable | Lident _ -> true + | Token.At | Mutable | Lident _ -> true (* recovery, TODO: this is not ideal… *) | Uident _ -> true | t when Token.isKeyword t -> true | _ -> false let isRecordDeclStart = function - | Token.At - | Mutable - | Lident _ -> true + | Token.At | Mutable | Lident _ -> true | _ -> false let isTypExprStart = function - | Token.At - | SingleQuote - | Underscore - | Lparen | Lbracket - | Uident _ | Lident _ - | Module - | Percent - | Lbrace -> true + | Token.At | SingleQuote | Underscore | Lparen | Lbracket | Uident _ + | Lident _ | Module | Percent | Lbrace -> + true | _ -> false let isTypeParameterStart = function @@ -249,16 +213,11 @@ let isTypeParamStart = function | _ -> false let isFunctorArgStart = function - | Token.At | Uident _ | Underscore - | Percent - | Lbrace - | Lparen -> true + | Token.At | Uident _ | Underscore | Percent | Lbrace | Lparen -> true | _ -> false let isModExprStart = function - | Token.At | Percent - | Uident _ | Lbrace | Lparen - | Lident "unpack" -> true + | Token.At | Percent | Uident _ | Lbrace | Lparen | Lident "unpack" -> true | _ -> false let isRecordRowStart = function @@ -302,11 +261,12 @@ let isJsFfiImportStart = function let isJsxChildStart = isAtomicExprStart let isBlockExprStart = function - | Token.At | Hash | Percent | Minus | MinusDot | Plus | PlusDot | Bang - | True | False | Float _ | Int _ | String _ | Codepoint _ | Lident _ | Uident _ - | Lparen | List | Lbracket | Lbrace | Forwardslash | Assert - | Lazy | If | For | While | Switch | Open | Module | Exception | Let - | LessThan | Backtick | Try | Underscore -> true + | Token.At | Hash | Percent | Minus | MinusDot | Plus | PlusDot | Bang | True + | False | Float _ | Int _ | String _ | Codepoint _ | Lident _ | Uident _ + | Lparen | List | Lbracket | Lbrace | Forwardslash | Assert | Lazy | If | For + | While | Switch | Open | Module | Exception | Let | LessThan | Backtick | Try + | Underscore -> + true | _ -> false let isListElement grammar token = @@ -342,30 +302,31 @@ let isListElement grammar token = | _ -> false let isListTerminator grammar token = - match grammar, token with + match (grammar, token) with | _, Token.Eof | ExprList, (Rparen | Forwardslash | Rbracket) | ListExpr, Rparen | ArgumentList, Rparen | TypExprList, (Rparen | Forwardslash | GreaterThan | Equal) | ModExprList, Rparen - | (PatternList | PatternOcamlList | PatternRecord), - (Forwardslash | Rbracket | Rparen | EqualGreater (* pattern matching => *) | In (* for expressions *) | Equal (* let {x} = foo *)) + | ( (PatternList | PatternOcamlList | PatternRecord), + ( Forwardslash | Rbracket | Rparen | EqualGreater (* pattern matching => *) + | In (* for expressions *) + | Equal (* let {x} = foo *) ) ) | ExprBlock, Rbrace | (Structure | Signature), Rbrace | TypeParams, Rparen | ParameterList, (EqualGreater | Lbrace) | JsxAttribute, (Forwardslash | GreaterThan) | JsFfiImport, Rbrace - | StringFieldDeclarations, Rbrace -> true - + | StringFieldDeclarations, Rbrace -> + true | Attribute, token when token <> At -> true | TypeConstraint, token when token <> Constraint -> true | PackageConstraint, token when token <> And -> true | ConstructorDeclaration, token when token <> Bar -> true | AttributePayload, Rparen -> true | TagNames, Rbracket -> true - | _ -> false let isPartOfList grammar token = diff --git a/src/res_io.ml b/src/res_io.ml index e5934b84..ef29399b 100644 --- a/src/res_io.ml +++ b/src/res_io.ml @@ -11,4 +11,4 @@ let writeFile ~filename ~contents:txt = let chan = open_out_bin filename in output_string chan txt; close_out chan -[@@raises Sys_error] + [@@raises Sys_error] diff --git a/src/res_io.mli b/src/res_io.mli index 6260c27c..dcc6e142 100644 --- a/src/res_io.mli +++ b/src/res_io.mli @@ -1,7 +1,7 @@ (* utilities to read and write to/from files or stdin *) (* reads the contents of "filename" into a string *) -val readFile: filename: string -> string +val readFile : filename:string -> string (* writes "content" into file with name "filename" *) -val writeFile: filename: string -> contents: string -> unit +val writeFile : filename:string -> contents:string -> unit diff --git a/src/res_js_ffi.ml b/src/res_js_ffi.ml index f8a082a1..3d02fb10 100644 --- a/src/res_js_ffi.ml +++ b/src/res_js_ffi.ml @@ -9,7 +9,7 @@ type label_declaration = { jld_name: string; jld_alias: string; jld_type: Parsetree.core_type; - jld_loc: Location.t + jld_loc: Location.t; } type importSpec = @@ -20,95 +20,100 @@ type import_description = { jid_loc: Location.t; jid_spec: importSpec; jid_scope: scope; - jid_attributes: Parsetree.attributes; + jid_attributes: Parsetree.attributes; } -let decl ~attrs ~loc ~name ~alias ~typ = { - jld_loc = loc; - jld_attributes = attrs; - jld_name = name; - jld_alias = alias; - jld_type = typ -} +let decl ~attrs ~loc ~name ~alias ~typ = + { + jld_loc = loc; + jld_attributes = attrs; + jld_name = name; + jld_alias = alias; + jld_type = typ; + } -let importDescr ~attrs ~scope ~importSpec ~loc = { - jid_loc = loc; - jid_spec = importSpec; - jid_scope = scope; - jid_attributes = attrs; -} +let importDescr ~attrs ~scope ~importSpec ~loc = + { + jid_loc = loc; + jid_spec = importSpec; + jid_scope = scope; + jid_attributes = attrs; + } let toParsetree importDescr = let bsVal = (Location.mknoloc "val", Parsetree.PStr []) in - let attrs = match importDescr.jid_scope with - | Global -> [bsVal] - (* @genType.import("./MyMath"), - * @genType.import(/"./MyMath", "default"/) *) - | Module s -> - let structure = [ - Parsetree.Pconst_string (s, None) - |> Ast_helper.Exp.constant - |> Ast_helper.Str.eval - ] in - let genType = (Location.mknoloc "genType.import", Parsetree.PStr structure) in - [genType] - | Scope longident -> - let structureItem = - let expr = match Longident.flatten longident |> List.map (fun s -> - Ast_helper.Exp.constant (Parsetree.Pconst_string (s, None)) - ) with - | [expr] -> expr - | [] as exprs | (_ as exprs) -> exprs |> Ast_helper.Exp.tuple + let attrs = + match importDescr.jid_scope with + | Global -> [bsVal] + (* @genType.import("./MyMath"), + * @genType.import(/"./MyMath", "default"/) *) + | Module s -> + let structure = + [ + Parsetree.Pconst_string (s, None) + |> Ast_helper.Exp.constant |> Ast_helper.Str.eval; + ] + in + let genType = + (Location.mknoloc "genType.import", Parsetree.PStr structure) in - Ast_helper.Str.eval expr - in - let bsScope = ( - Location.mknoloc "scope", - Parsetree. PStr [structureItem] - ) in - [bsVal; bsScope] + [genType] + | Scope longident -> + let structureItem = + let expr = + match + Longident.flatten longident + |> List.map (fun s -> + Ast_helper.Exp.constant (Parsetree.Pconst_string (s, None))) + with + | [expr] -> expr + | ([] as exprs) | (_ as exprs) -> exprs |> Ast_helper.Exp.tuple + in + Ast_helper.Str.eval expr + in + let bsScope = + (Location.mknoloc "scope", Parsetree.PStr [structureItem]) + in + [bsVal; bsScope] in - let valueDescrs = match importDescr.jid_spec with - | Default decl -> - let prim = [decl.jld_name] in - let allAttrs = - List.concat [attrs; importDescr.jid_attributes] - |> List.map (fun attr -> match attr with - | ( - {Location.txt = "genType.import"} as id, - Parsetree.PStr [{pstr_desc = Parsetree.Pstr_eval (moduleName, _) }] - ) -> - let default = - Parsetree.Pconst_string ("default", None) |> Ast_helper.Exp.constant - in - let structureItem = - [moduleName; default] - |> Ast_helper.Exp.tuple - |> Ast_helper.Str.eval - in - (id, Parsetree.PStr [structureItem]) - | attr -> attr - ) - in - [Ast_helper.Val.mk - ~loc:importDescr.jid_loc - ~prim - ~attrs:allAttrs - (Location.mknoloc decl.jld_alias) - decl.jld_type - |> Ast_helper.Str.primitive] - | Spec decls -> - List.map (fun decl -> + let valueDescrs = + match importDescr.jid_spec with + | Default decl -> let prim = [decl.jld_name] in - let allAttrs = List.concat [attrs; decl.jld_attributes] in - Ast_helper.Val.mk - ~loc:importDescr.jid_loc - ~prim - ~attrs:allAttrs - (Location.mknoloc decl.jld_alias) - decl.jld_type - |> Ast_helper.Str.primitive ~loc:decl.jld_loc - ) decls + let allAttrs = + List.concat [attrs; importDescr.jid_attributes] + |> List.map (fun attr -> + match attr with + | ( ({Location.txt = "genType.import"} as id), + Parsetree.PStr + [{pstr_desc = Parsetree.Pstr_eval (moduleName, _)}] ) -> + let default = + Parsetree.Pconst_string ("default", None) + |> Ast_helper.Exp.constant + in + let structureItem = + [moduleName; default] |> Ast_helper.Exp.tuple + |> Ast_helper.Str.eval + in + (id, Parsetree.PStr [structureItem]) + | attr -> attr) + in + [ + Ast_helper.Val.mk ~loc:importDescr.jid_loc ~prim ~attrs:allAttrs + (Location.mknoloc decl.jld_alias) + decl.jld_type + |> Ast_helper.Str.primitive; + ] + | Spec decls -> + List.map + (fun decl -> + let prim = [decl.jld_name] in + let allAttrs = List.concat [attrs; decl.jld_attributes] in + Ast_helper.Val.mk ~loc:importDescr.jid_loc ~prim ~attrs:allAttrs + (Location.mknoloc decl.jld_alias) + decl.jld_type + |> Ast_helper.Str.primitive ~loc:decl.jld_loc) + decls in let jsFfiAttr = (Location.mknoloc "ns.jsFfi", Parsetree.PStr []) in Ast_helper.Mod.structure ~loc:importDescr.jid_loc valueDescrs diff --git a/src/res_minibuffer.ml b/src/res_minibuffer.ml index 174b5ec6..d36a1679 100644 --- a/src/res_minibuffer.ml +++ b/src/res_minibuffer.ml @@ -1,13 +1,9 @@ -type t = { - mutable buffer : bytes; - mutable position : int; - mutable length : int; -} +type t = {mutable buffer: bytes; mutable position: int; mutable length: int} let create n = - let n = if n < 1 then 1 else n in - let s = (Bytes.create [@doesNotRaise]) n in - {buffer = s; position = 0; length = n} + let n = if n < 1 then 1 else n in + let s = (Bytes.create [@doesNotRaise]) n in + {buffer = s; position = 0; length = n} let contents b = (Bytes.sub_string [@doesNotRaise]) b.buffer 0 b.position @@ -15,11 +11,12 @@ let contents b = (Bytes.sub_string [@doesNotRaise]) b.buffer 0 b.position let resize_internal b more = let len = b.length in let new_len = ref len in - while b.position + more > !new_len do new_len := 2 * !new_len done; - if !new_len > Sys.max_string_length then begin - if b.position + more <= Sys.max_string_length - then new_len := Sys.max_string_length - end; + while b.position + more > !new_len do + new_len := 2 * !new_len + done; + if !new_len > Sys.max_string_length then + if b.position + more <= Sys.max_string_length then + new_len := Sys.max_string_length; let new_buffer = (Bytes.create [@doesNotRaise]) !new_len in (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in this tricky function that is slow anyway. *) @@ -42,9 +39,9 @@ let add_string b s = (* adds newline and trims all preceding whitespace *) let flush_newline b = - let position = ref (b.position) in - while (Bytes.unsafe_get b.buffer (!position - 1)) = ' ' && !position >= 0 do - position := !position - 1; + let position = ref b.position in + while Bytes.unsafe_get b.buffer (!position - 1) = ' ' && !position >= 0 do + position := !position - 1 done; b.position <- !position; add_char b '\n' diff --git a/src/res_multi_printer.ml b/src/res_multi_printer.ml index 5190f1fa..a9d65cb8 100644 --- a/src/res_multi_printer.ml +++ b/src/res_multi_printer.ml @@ -6,48 +6,40 @@ let printRes ~isInterface ~filename = let parseResult = Res_driver.parsingEngine.parseInterface ~forPrinter:true ~filename in - if parseResult.invalid then - begin - Res_diagnostics.printReport parseResult.diagnostics parseResult.source; - exit 1 - end + if parseResult.invalid then ( + Res_diagnostics.printReport parseResult.diagnostics parseResult.source; + exit 1) else - Res_printer.printInterface - ~width:defaultPrintWidth - ~comments:parseResult.comments - parseResult.parsetree + Res_printer.printInterface ~width:defaultPrintWidth + ~comments:parseResult.comments parseResult.parsetree else let parseResult = Res_driver.parsingEngine.parseImplementation ~forPrinter:true ~filename in - if parseResult.invalid then - begin - Res_diagnostics.printReport parseResult.diagnostics parseResult.source; - exit 1 - end + if parseResult.invalid then ( + Res_diagnostics.printReport parseResult.diagnostics parseResult.source; + exit 1) else - Res_printer.printImplementation - ~width:defaultPrintWidth - ~comments:parseResult.comments - parseResult.parsetree -[@@raises exit] + Res_printer.printImplementation ~width:defaultPrintWidth + ~comments:parseResult.comments parseResult.parsetree + [@@raises exit] (* print ocaml files to res syntax *) let printMl ~isInterface ~filename = if isInterface then let parseResult = - Res_driver_ml_parser.parsingEngine.parseInterface ~forPrinter:true ~filename in - Res_printer.printInterface - ~width:defaultPrintWidth - ~comments:parseResult.comments - parseResult.parsetree + Res_driver_ml_parser.parsingEngine.parseInterface ~forPrinter:true + ~filename + in + Res_printer.printInterface ~width:defaultPrintWidth + ~comments:parseResult.comments parseResult.parsetree else let parseResult = - Res_driver_ml_parser.parsingEngine.parseImplementation ~forPrinter:true ~filename in - Res_printer.printImplementation - ~width:defaultPrintWidth - ~comments:parseResult.comments - parseResult.parsetree + Res_driver_ml_parser.parsingEngine.parseImplementation ~forPrinter:true + ~filename + in + Res_printer.printImplementation ~width:defaultPrintWidth + ~comments:parseResult.comments parseResult.parsetree (* print the given file named input to from "language" to res, general interface exposed by the compiler *) let print language ~input = @@ -58,4 +50,4 @@ let print language ~input = match language with | `res -> printRes ~isInterface ~filename:input | `ml -> printMl ~isInterface ~filename:input -[@@raises exit] + [@@raises exit] diff --git a/src/res_multi_printer.mli b/src/res_multi_printer.mli index 724f712f..f18043fb 100644 --- a/src/res_multi_printer.mli +++ b/src/res_multi_printer.mli @@ -1,3 +1,3 @@ (* Interface to print source code from different languages to res. * Takes a filename called "input" and returns the corresponding formatted res syntax *) -val print: [`ml | `res] -> input: string -> string +val print : [`ml | `res] -> input:string -> string diff --git a/src/res_outcome_printer.ml b/src/res_outcome_printer.ml index bd2bdacd..1bf55ef1 100644 --- a/src/res_outcome_printer.ml +++ b/src/res_outcome_printer.ml @@ -11,37 +11,36 @@ module Doc = Res_doc module Token = Res_token let rec unsafe_for_all_range s ~start ~finish p = - start > finish || - p (String.unsafe_get s start) && - unsafe_for_all_range s ~start:(start + 1) ~finish p + start > finish + || p (String.unsafe_get s start) + && unsafe_for_all_range s ~start:(start + 1) ~finish p -let for_all_from s start p = +let for_all_from s start p = let len = String.length s in unsafe_for_all_range s ~start ~finish:(len - 1) p (* See https://github.com/rescript-lang/rescript-compiler/blob/726cfa534314b586e5b5734471bc2023ad99ebd9/jscomp/ext/ext_string.ml#L510 *) let isValidNumericPolyvarNumber (x : string) = let len = String.length x in - len > 0 && ( - let a = Char.code (String.unsafe_get x 0) in - a <= 57 && - (if len > 1 then - a > 48 && - for_all_from x 1 (function '0' .. '9' -> true | _ -> false) - else - a >= 48 ) - ) + len > 0 + && + let a = Char.code (String.unsafe_get x 0) in + a <= 57 + && + if len > 1 then + a > 48 + && for_all_from x 1 (function + | '0' .. '9' -> true + | _ -> false) + else a >= 48 (* checks if ident contains "arity", like in "arity1", "arity2", "arity3" etc. *) let isArityIdent ident = if String.length ident >= 6 then (String.sub [@doesNotRaise]) ident 0 5 = "arity" - else - false + else false -type identifierStyle = - | ExoticIdent - | NormalIdent +type identifierStyle = ExoticIdent | NormalIdent let classifyIdentContent ~allowUident txt = let len = String.length txt in @@ -49,1165 +48,1112 @@ let classifyIdentContent ~allowUident txt = if i == len then NormalIdent else let c = String.unsafe_get txt i in - if i == 0 && not ( - (allowUident && (c >= 'A' && c <= 'Z')) || - (c >= 'a' && c <= 'z') || c = '_') then - ExoticIdent - else if not ( - (c >= 'a' && c <= 'z') - || (c >= 'A' && c <= 'Z') - || c = '\'' - || c = '_' - || (c >= '0' && c <= '9')) - then - ExoticIdent - else - go (i + 1) + if + i == 0 + && not + ((allowUident && c >= 'A' && c <= 'Z') + || (c >= 'a' && c <= 'z') + || c = '_') + then ExoticIdent + else if + not + ((c >= 'a' && c <= 'z') + || (c >= 'A' && c <= 'Z') + || c = '\'' || c = '_' + || (c >= '0' && c <= '9')) + then ExoticIdent + else go (i + 1) in - if Token.isKeywordTxt txt then - ExoticIdent - else - go 0 + if Token.isKeywordTxt txt then ExoticIdent else go 0 let printIdentLike ~allowUident txt = match classifyIdentContent ~allowUident txt with - | ExoticIdent -> Doc.concat [ - Doc.text "\\\""; - Doc.text txt; - Doc.text"\"" - ] + | ExoticIdent -> Doc.concat [Doc.text "\\\""; Doc.text txt; Doc.text "\""] | NormalIdent -> Doc.text txt let printPolyVarIdent txt = (* numeric poly-vars don't need quotes: #644 *) - if isValidNumericPolyvarNumber txt then - Doc.text txt + if isValidNumericPolyvarNumber txt then Doc.text txt else match classifyIdentContent ~allowUident:true txt with - | ExoticIdent -> Doc.concat [ - Doc.text "\""; - Doc.text txt; - Doc.text"\"" - ] + | ExoticIdent -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] | NormalIdent -> Doc.text txt - (* ReScript doesn't have parenthesized identifiers. - * We don't support custom operators. *) - let parenthesized_ident _name = true +(* ReScript doesn't have parenthesized identifiers. + * We don't support custom operators. *) +let parenthesized_ident _name = true - (* TODO: better allocation strategy for the buffer *) - let escapeStringContents s = - let len = String.length s in - let b = Buffer.create len in - for i = 0 to len - 1 do - let c = (String.get [@doesNotRaise]) s i in - if c = '\008' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'b'; - ) else if c = '\009' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 't'; - ) else if c = '\010' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'n'; - ) else if c = '\013' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'r'; - ) else if c = '\034' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '"'; - ) else if c = '\092' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '\\'; - ) else ( - Buffer.add_char b c; - ); - done; - Buffer.contents b +(* TODO: better allocation strategy for the buffer *) +let escapeStringContents s = + let len = String.length s in + let b = Buffer.create len in + for i = 0 to len - 1 do + let c = (String.get [@doesNotRaise]) s i in + if c = '\008' then ( + Buffer.add_char b '\\'; + Buffer.add_char b 'b') + else if c = '\009' then ( + Buffer.add_char b '\\'; + Buffer.add_char b 't') + else if c = '\010' then ( + Buffer.add_char b '\\'; + Buffer.add_char b 'n') + else if c = '\013' then ( + Buffer.add_char b '\\'; + Buffer.add_char b 'r') + else if c = '\034' then ( + Buffer.add_char b '\\'; + Buffer.add_char b '"') + else if c = '\092' then ( + Buffer.add_char b '\\'; + Buffer.add_char b '\\') + else Buffer.add_char b c + done; + Buffer.contents b - (* let rec print_ident fmt ident = match ident with - | Outcometree.Oide_ident s -> Format.pp_print_string fmt s - | Oide_dot (id, s) -> - print_ident fmt id; - Format.pp_print_char fmt '.'; - Format.pp_print_string fmt s - | Oide_apply (id1, id2) -> - print_ident fmt id1; - Format.pp_print_char fmt '('; - print_ident fmt id2; - Format.pp_print_char fmt ')' *) +(* let rec print_ident fmt ident = match ident with + | Outcometree.Oide_ident s -> Format.pp_print_string fmt s + | Oide_dot (id, s) -> + print_ident fmt id; + Format.pp_print_char fmt '.'; + Format.pp_print_string fmt s + | Oide_apply (id1, id2) -> + print_ident fmt id1; + Format.pp_print_char fmt '('; + print_ident fmt id2; + Format.pp_print_char fmt ')' *) - let rec printOutIdentDoc ?(allowUident=true) (ident : Outcometree.out_ident) = - match ident with - | Oide_ident s -> printIdentLike ~allowUident s - | Oide_dot (ident, s) -> Doc.concat [ - printOutIdentDoc ident; - Doc.dot; - Doc.text s; - ] - | Oide_apply (call, arg) ->Doc.concat [ - printOutIdentDoc call; - Doc.lparen; - printOutIdentDoc arg; - Doc.rparen; - ] +let rec printOutIdentDoc ?(allowUident = true) (ident : Outcometree.out_ident) = + match ident with + | Oide_ident s -> printIdentLike ~allowUident s + | Oide_dot (ident, s) -> + Doc.concat [printOutIdentDoc ident; Doc.dot; Doc.text s] + | Oide_apply (call, arg) -> + Doc.concat + [printOutIdentDoc call; Doc.lparen; printOutIdentDoc arg; Doc.rparen] - let printOutAttributeDoc (outAttribute: Outcometree.out_attribute) = - Doc.concat [ - Doc.text "@"; - Doc.text outAttribute.oattr_name; - ] +let printOutAttributeDoc (outAttribute : Outcometree.out_attribute) = + Doc.concat [Doc.text "@"; Doc.text outAttribute.oattr_name] - let printOutAttributesDoc (attrs: Outcometree.out_attribute list) = - match attrs with - | [] -> Doc.nil - | attrs -> - Doc.concat [ - Doc.group ( - Doc.join ~sep:Doc.line (List.map printOutAttributeDoc attrs) - ); - Doc.line; - ] +let printOutAttributesDoc (attrs : Outcometree.out_attribute list) = + match attrs with + | [] -> Doc.nil + | attrs -> + Doc.concat + [ + Doc.group (Doc.join ~sep:Doc.line (List.map printOutAttributeDoc attrs)); + Doc.line; + ] - let rec collectArrowArgs (outType: Outcometree.out_type) args = - match outType with - | Otyp_arrow (label, argType, returnType) -> - let arg = (label, argType) in - collectArrowArgs returnType (arg::args) - | _ as returnType -> - (List.rev args, returnType) +let rec collectArrowArgs (outType : Outcometree.out_type) args = + match outType with + | Otyp_arrow (label, argType, returnType) -> + let arg = (label, argType) in + collectArrowArgs returnType (arg :: args) + | _ as returnType -> (List.rev args, returnType) - let rec collectFunctorArgs (outModuleType: Outcometree.out_module_type) args = - match outModuleType with - | Omty_functor (lbl, optModType, returnModType) -> - let arg = (lbl, optModType) in - collectFunctorArgs returnModType (arg::args) - | _ -> - (List.rev args, outModuleType) +let rec collectFunctorArgs (outModuleType : Outcometree.out_module_type) args = + match outModuleType with + | Omty_functor (lbl, optModType, returnModType) -> + let arg = (lbl, optModType) in + collectFunctorArgs returnModType (arg :: args) + | _ -> (List.rev args, outModuleType) - let rec printOutTypeDoc (outType: Outcometree.out_type) = - match outType with - | Otyp_abstract | Otyp_open -> Doc.nil - | Otyp_variant (nonGen, outVariant, closed, labels) -> - (* bool * out_variant * bool * (string list) option *) - let opening = match (closed, labels) with - | (true, None) -> (* [#A | #B] *) Doc.softLine - | (false, None) -> +let rec printOutTypeDoc (outType : Outcometree.out_type) = + match outType with + | Otyp_abstract | Otyp_open -> Doc.nil + | Otyp_variant (nonGen, outVariant, closed, labels) -> + (* bool * out_variant * bool * (string list) option *) + let opening = + match (closed, labels) with + | true, None -> (* [#A | #B] *) Doc.softLine + | false, None -> (* [> #A | #B] *) Doc.concat [Doc.greaterThan; Doc.line] - | (true, Some []) -> + | true, Some [] -> (* [< #A | #B] *) Doc.concat [Doc.lessThan; Doc.line] - | (true, Some _) -> + | true, Some _ -> (* [< #A | #B > #X #Y ] *) Doc.concat [Doc.lessThan; Doc.line] - | (false, Some _) -> - (* impossible!? ocaml seems to print ?, see oprint.ml in 4.06 *) + | false, Some _ -> + (* impossible!? ocaml seems to print ?, see oprint.ml in 4.06 *) Doc.concat [Doc.text "?"; Doc.line] - in - Doc.group ( - Doc.concat [ - if nonGen then Doc.text "_" else Doc.nil; + in + Doc.group + (Doc.concat + [ + (if nonGen then Doc.text "_" else Doc.nil); Doc.lbracket; - Doc.indent ( - Doc.concat [ - opening; - printOutVariant outVariant - ] - ); - begin match labels with + Doc.indent (Doc.concat [opening; printOutVariant outVariant]); + (match labels with | None | Some [] -> Doc.nil | Some tags -> - Doc.group ( - Doc.concat [ - Doc.space; - Doc.join ~sep:Doc.space ( - List.map (fun lbl -> printIdentLike ~allowUident:true lbl) tags - ) - ] - ) - end; + Doc.group + (Doc.concat + [ + Doc.space; + Doc.join ~sep:Doc.space + (List.map + (fun lbl -> printIdentLike ~allowUident:true lbl) + tags); + ])); Doc.softLine; Doc.rbracket; - ] - ) - | Otyp_alias (typ, aliasTxt) -> - Doc.concat [ - Doc.lparen; - printOutTypeDoc typ; - Doc.text " as '"; - Doc.text aliasTxt; - Doc.rparen - ] - | Otyp_constr ( - Oide_dot (Oide_dot (Oide_ident "Js", "Fn") , "arity0"), (* Js.Fn.arity0 *) - [typ] - ) -> - (* Js.Fn.arity0 -> (.) => t *) - Doc.concat [ - Doc.text "(. ()) => "; - printOutTypeDoc typ; - ] - | Otyp_constr ( - Oide_dot (Oide_dot (Oide_ident "Js", "Fn") , ident), (* Js.Fn.arity2 *) - [(Otyp_arrow _) as arrowType] (* (int, int) => int *) - ) when isArityIdent ident -> - (* Js.Fn.arity2<(int, int) => int> -> (. int, int) => int*) - printOutArrowType ~uncurried:true arrowType - | Otyp_constr (outIdent, []) -> - printOutIdentDoc ~allowUident:false outIdent - | Otyp_manifest (typ1, typ2) -> - Doc.concat [ - printOutTypeDoc typ1; - Doc.text " = "; - printOutTypeDoc typ2; - ] - | Otyp_record record -> - printRecordDeclarationDoc ~inline:true record - | Otyp_stuff txt -> Doc.text txt - | Otyp_var (ng, s) -> Doc.concat [ - Doc.text ("'" ^ (if ng then "_" else "")); - Doc.text s - ] - | Otyp_object (fields, rest) -> printObjectFields fields rest - | Otyp_class _ -> Doc.nil - | Otyp_attribute (typ, attribute) -> - Doc.group ( - Doc.concat [ - printOutAttributeDoc attribute; - Doc.line; - printOutTypeDoc typ; - ] - ) - (* example: Red | Blue | Green | CustomColour(float, float, float) *) - | Otyp_sum constructors -> - printOutConstructorsDoc constructors - - (* example: {"name": string, "age": int} *) - | Otyp_constr ( - (Oide_dot ((Oide_ident "Js"), "t")), - [Otyp_object (fields, rest)] - ) -> printObjectFields fields rest - - (* example: node *) - | Otyp_constr (outIdent, args) -> - let argsDoc = match args with - | [] -> Doc.nil - | args -> - Doc.concat [ - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutTypeDoc args - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ] - in - Doc.group ( - Doc.concat [ - printOutIdentDoc outIdent; - argsDoc; - ] - ) - | Otyp_tuple tupleArgs -> - Doc.group ( - Doc.concat [ + ]) + | Otyp_alias (typ, aliasTxt) -> + Doc.concat + [ + Doc.lparen; + printOutTypeDoc typ; + Doc.text " as '"; + Doc.text aliasTxt; + Doc.rparen; + ] + | Otyp_constr + ( Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), "arity0"), + (* Js.Fn.arity0 *) + [typ] ) -> + (* Js.Fn.arity0 -> (.) => t *) + Doc.concat [Doc.text "(. ()) => "; printOutTypeDoc typ] + | Otyp_constr + ( Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), ident), + (* Js.Fn.arity2 *) + [(Otyp_arrow _ as arrowType)] (* (int, int) => int *) ) + when isArityIdent ident -> + (* Js.Fn.arity2<(int, int) => int> -> (. int, int) => int*) + printOutArrowType ~uncurried:true arrowType + | Otyp_constr (outIdent, []) -> printOutIdentDoc ~allowUident:false outIdent + | Otyp_manifest (typ1, typ2) -> + Doc.concat [printOutTypeDoc typ1; Doc.text " = "; printOutTypeDoc typ2] + | Otyp_record record -> printRecordDeclarationDoc ~inline:true record + | Otyp_stuff txt -> Doc.text txt + | Otyp_var (ng, s) -> + Doc.concat [Doc.text ("'" ^ if ng then "_" else ""); Doc.text s] + | Otyp_object (fields, rest) -> printObjectFields fields rest + | Otyp_class _ -> Doc.nil + | Otyp_attribute (typ, attribute) -> + Doc.group + (Doc.concat + [printOutAttributeDoc attribute; Doc.line; printOutTypeDoc typ]) + (* example: Red | Blue | Green | CustomColour(float, float, float) *) + | Otyp_sum constructors -> printOutConstructorsDoc constructors + (* example: {"name": string, "age": int} *) + | Otyp_constr (Oide_dot (Oide_ident "Js", "t"), [Otyp_object (fields, rest)]) + -> + printObjectFields fields rest + (* example: node *) + | Otyp_constr (outIdent, args) -> + let argsDoc = + match args with + | [] -> Doc.nil + | args -> + Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map printOutTypeDoc args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ] + in + Doc.group (Doc.concat [printOutIdentDoc outIdent; argsDoc]) + | Otyp_tuple tupleArgs -> + Doc.group + (Doc.concat + [ Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutTypeDoc tupleArgs - ) - ] - ); + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map printOutTypeDoc tupleArgs); + ]); Doc.trailingComma; Doc.softLine; Doc.rparen; - ] - ) - | Otyp_poly (vars, outType) -> - Doc.group ( - Doc.concat [ - Doc.join ~sep:Doc.space ( - List.map (fun var -> Doc.text ("'" ^ var)) vars - ); + ]) + | Otyp_poly (vars, outType) -> + Doc.group + (Doc.concat + [ + Doc.join ~sep:Doc.space + (List.map (fun var -> Doc.text ("'" ^ var)) vars); Doc.dot; Doc.space; printOutTypeDoc outType; - ] - ) - | Otyp_arrow _ as typ -> - printOutArrowType ~uncurried:false typ - | Otyp_module (modName, stringList, outTypes) -> - let packageTypeDoc = match (stringList, outTypes) with + ]) + | Otyp_arrow _ as typ -> printOutArrowType ~uncurried:false typ + | Otyp_module (modName, stringList, outTypes) -> + let packageTypeDoc = + match (stringList, outTypes) with | [], [] -> Doc.nil | labels, types -> let i = ref 0 in - let package = Doc.join ~sep:Doc.line ((List.map2 [@doesNotRaise]) (fun lbl typ -> - Doc.concat [ - Doc.text (if i.contents > 0 then "and type " else "with type "); - Doc.text lbl; - Doc.text " = "; - printOutTypeDoc typ; - ] - ) labels types) + let package = + Doc.join ~sep:Doc.line + ((List.map2 [@doesNotRaise]) + (fun lbl typ -> + Doc.concat + [ + Doc.text + (if i.contents > 0 then "and type " else "with type "); + Doc.text lbl; + Doc.text " = "; + printOutTypeDoc typ; + ]) + labels types) in - Doc.indent ( - Doc.concat [ - Doc.line; - package - ] - ) - in - Doc.concat [ - Doc.text "module"; - Doc.lparen; - Doc.text modName; - packageTypeDoc; - Doc.rparen; - ] + Doc.indent (Doc.concat [Doc.line; package]) + in + Doc.concat + [ + Doc.text "module"; + Doc.lparen; + Doc.text modName; + packageTypeDoc; + Doc.rparen; + ] - and printOutArrowType ~uncurried typ = - let (typArgs, typ) = collectArrowArgs typ [] in - let args = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun (lbl, typ) -> - let lblLen = String.length lbl in - if lblLen = 0 then - printOutTypeDoc typ - else - let (lbl, optionalIndicator) = - (* the ocaml compiler hardcodes the optional label inside the string of the label in printtyp.ml *) - match String.unsafe_get lbl 0 with - | '?' -> ((String.sub [@doesNotRaise]) lbl 1 (lblLen - 1) , Doc.text "=?") - | _ -> (lbl, Doc.nil) - in - Doc.group ( - Doc.concat [ - Doc.text ("~" ^ lbl ^ ": "); - printOutTypeDoc typ; - optionalIndicator - ] - ) - ) typArgs - ) in - let argsDoc = - let needsParens = match typArgs with - | _ when uncurried -> true - | [_, (Otyp_tuple _ | Otyp_arrow _)] -> true - (* single argument should not be wrapped *) - | ["", _] -> false - | _ -> true - in - if needsParens then - Doc.group ( - Doc.concat [ - if uncurried then Doc.text "(. " else Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - args; - ] - ); +and printOutArrowType ~uncurried typ = + let typArgs, typ = collectArrowArgs typ [] in + let args = + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun (lbl, typ) -> + let lblLen = String.length lbl in + if lblLen = 0 then printOutTypeDoc typ + else + let lbl, optionalIndicator = + (* the ocaml compiler hardcodes the optional label inside the string of the label in printtyp.ml *) + match String.unsafe_get lbl 0 with + | '?' -> + ((String.sub [@doesNotRaise]) lbl 1 (lblLen - 1), Doc.text "=?") + | _ -> (lbl, Doc.nil) + in + Doc.group + (Doc.concat + [ + Doc.text ("~" ^ lbl ^ ": "); + printOutTypeDoc typ; + optionalIndicator; + ])) + typArgs) + in + let argsDoc = + let needsParens = + match typArgs with + | _ when uncurried -> true + | [(_, (Otyp_tuple _ | Otyp_arrow _))] -> true + (* single argument should not be wrapped *) + | [("", _)] -> false + | _ -> true + in + if needsParens then + Doc.group + (Doc.concat + [ + (if uncurried then Doc.text "(. " else Doc.lparen); + Doc.indent (Doc.concat [Doc.softLine; args]); Doc.trailingComma; Doc.softLine; Doc.rparen; - ] - ) - else args - in - Doc.concat [ - argsDoc; - Doc.text " => "; - printOutTypeDoc typ; - ] - + ]) + else args + in + Doc.concat [argsDoc; Doc.text " => "; printOutTypeDoc typ] - and printOutVariant variant = match variant with - | Ovar_fields fields -> (* (string * bool * out_type list) list *) - Doc.join ~sep:Doc.line ( - (* - * [< | #T([< u2]) & ([< u2]) & ([< u1])] --> no ampersand - * [< | #S & ([< u2]) & ([< u2]) & ([< u1])] --> ampersand - *) - List.mapi (fun i (name, ampersand, types) -> - let needsParens = match types with - | [(Outcometree.Otyp_tuple _)] -> false - | _ -> true +and printOutVariant variant = + match variant with + | Ovar_fields fields -> + (* (string * bool * out_type list) list *) + Doc.join ~sep:Doc.line + ((* + * [< | #T([< u2]) & ([< u2]) & ([< u1])] --> no ampersand + * [< | #S & ([< u2]) & ([< u2]) & ([< u1])] --> ampersand + *) + List.mapi + (fun i (name, ampersand, types) -> + let needsParens = + match types with + | [Outcometree.Otyp_tuple _] -> false + | _ -> true in - Doc.concat [ - if i > 0 then - Doc.text "| " - else - Doc.ifBreaks (Doc.text "| ") Doc.nil; - Doc.group ( - Doc.concat [ - Doc.text "#"; - printPolyVarIdent name; - match types with - | [] -> Doc.nil - | types -> - Doc.concat [ - if ampersand then Doc.text " & " else Doc.nil; - Doc.indent ( - Doc.concat [ - Doc.join ~sep:(Doc.concat [Doc.text " &"; Doc.line]) - (List.map (fun typ -> - let outTypeDoc = printOutTypeDoc typ in - if needsParens then - Doc.concat [Doc.lparen; outTypeDoc; Doc.rparen] - else - outTypeDoc - ) types) - ]; - ); - ] - ] - ) - ] - ) fields - ) - | Ovar_typ typ -> printOutTypeDoc typ + Doc.concat + [ + (if i > 0 then Doc.text "| " + else Doc.ifBreaks (Doc.text "| ") Doc.nil); + Doc.group + (Doc.concat + [ + Doc.text "#"; + printPolyVarIdent name; + (match types with + | [] -> Doc.nil + | types -> + Doc.concat + [ + (if ampersand then Doc.text " & " else Doc.nil); + Doc.indent + (Doc.concat + [ + Doc.join + ~sep:(Doc.concat [Doc.text " &"; Doc.line]) + (List.map + (fun typ -> + let outTypeDoc = + printOutTypeDoc typ + in + if needsParens then + Doc.concat + [ + Doc.lparen; + outTypeDoc; + Doc.rparen; + ] + else outTypeDoc) + types); + ]); + ]); + ]); + ]) + fields) + | Ovar_typ typ -> printOutTypeDoc typ - and printObjectFields fields rest = - let dots = match rest with - | Some non_gen -> Doc.text ((if non_gen then "_" else "") ^ "..") - | None -> if fields = [] then Doc.dot else Doc.nil - in - Doc.group ( - Doc.concat [ +and printObjectFields fields rest = + let dots = + match rest with + | Some non_gen -> Doc.text ((if non_gen then "_" else "") ^ "..") + | None -> if fields = [] then Doc.dot else Doc.nil + in + Doc.group + (Doc.concat + [ Doc.lbrace; dots; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun (lbl, outType) -> Doc.group ( - Doc.concat [ - Doc.text ("\"" ^ lbl ^ "\": "); - printOutTypeDoc outType; - ] - )) fields - ) - ] - ); + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun (lbl, outType) -> + Doc.group + (Doc.concat + [ + Doc.text ("\"" ^ lbl ^ "\": "); + printOutTypeDoc outType; + ])) + fields); + ]); Doc.trailingComma; Doc.softLine; Doc.rbrace; - ] - ) - + ]) - and printOutConstructorsDoc constructors = - Doc.group ( - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:Doc.line ( - List.mapi (fun i constructor -> - Doc.concat [ - if i > 0 then Doc.text "| " else Doc.ifBreaks (Doc.text "| ") Doc.nil; - printOutConstructorDoc constructor; - ] - ) constructors - ) - ] - ) - ) +and printOutConstructorsDoc constructors = + Doc.group + (Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join ~sep:Doc.line + (List.mapi + (fun i constructor -> + Doc.concat + [ + (if i > 0 then Doc.text "| " + else Doc.ifBreaks (Doc.text "| ") Doc.nil); + printOutConstructorDoc constructor; + ]) + constructors); + ])) - and printOutConstructorDoc (name, args, gadt) = - let gadtDoc = match gadt with - | Some outType -> - Doc.concat [ - Doc.text ": "; - printOutTypeDoc outType - ] - | None -> Doc.nil - in - let argsDoc = match args with - | [] -> Doc.nil - | [Otyp_record record] -> - (* inline records - * | Root({ - * mutable value: 'value, - * mutable updatedTime: float, - * }) - *) - Doc.concat [ - Doc.lparen; - Doc.indent ( - printRecordDeclarationDoc ~inline:true record; - ); - Doc.rparen; - ] - | _types -> - Doc.indent ( - Doc.concat [ +and printOutConstructorDoc (name, args, gadt) = + let gadtDoc = + match gadt with + | Some outType -> Doc.concat [Doc.text ": "; printOutTypeDoc outType] + | None -> Doc.nil + in + let argsDoc = + match args with + | [] -> Doc.nil + | [Otyp_record record] -> + (* inline records + * | Root({ + * mutable value: 'value, + * mutable updatedTime: float, + * }) + *) + Doc.concat + [ + Doc.lparen; + Doc.indent (printRecordDeclarationDoc ~inline:true record); + Doc.rparen; + ] + | _types -> + Doc.indent + (Doc.concat + [ Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutTypeDoc args - ) - ] - ); + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map printOutTypeDoc args); + ]); Doc.trailingComma; Doc.softLine; Doc.rparen; - ] - ) - in - Doc.group ( - Doc.concat [ - Doc.text name; - argsDoc; - gadtDoc - ] - ) + ]) + in + Doc.group (Doc.concat [Doc.text name; argsDoc; gadtDoc]) - and printRecordDeclRowDoc (name, mut, arg) = - Doc.group ( - Doc.concat [ - if mut then Doc.text "mutable " else Doc.nil; +and printRecordDeclRowDoc (name, mut, arg) = + Doc.group + (Doc.concat + [ + (if mut then Doc.text "mutable " else Doc.nil); printIdentLike ~allowUident:false name; Doc.text ": "; printOutTypeDoc arg; - ] - ) - - and printRecordDeclarationDoc ~inline rows = - let content = Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printRecordDeclRowDoc rows - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] in - if not inline then - Doc.group content - else content + ]) - let printOutType fmt outType = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutTypeDoc outType)) +and printRecordDeclarationDoc ~inline rows = + let content = + Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map printRecordDeclRowDoc rows); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ] + in + if not inline then Doc.group content else content - let printTypeParameterDoc (typ, (co, cn)) = - Doc.concat [ - if not cn then Doc.text "+" else if not co then Doc.text "-" else Doc.nil; - if typ = "_" then Doc.text "_" else Doc.text ("'" ^ typ) - ] +let printOutType fmt outType = + Format.pp_print_string fmt (Doc.toString ~width:80 (printOutTypeDoc outType)) +let printTypeParameterDoc (typ, (co, cn)) = + Doc.concat + [ + (if not cn then Doc.text "+" else if not co then Doc.text "-" else Doc.nil); + (if typ = "_" then Doc.text "_" else Doc.text ("'" ^ typ)); + ] - let rec printOutSigItemDoc (outSigItem : Outcometree.out_sig_item) = - match outSigItem with - | Osig_class _ | Osig_class_type _ -> Doc.nil - | Osig_ellipsis -> Doc.dotdotdot - | Osig_value valueDecl -> - Doc.group ( - Doc.concat [ +let rec printOutSigItemDoc (outSigItem : Outcometree.out_sig_item) = + match outSigItem with + | Osig_class _ | Osig_class_type _ -> Doc.nil + | Osig_ellipsis -> Doc.dotdotdot + | Osig_value valueDecl -> + Doc.group + (Doc.concat + [ printOutAttributesDoc valueDecl.oval_attributes; - Doc.text ( - match valueDecl.oval_prims with | [] -> "let " | _ -> "external " - ); + Doc.text + (match valueDecl.oval_prims with + | [] -> "let " + | _ -> "external "); Doc.text valueDecl.oval_name; Doc.text ":"; Doc.space; printOutTypeDoc valueDecl.oval_type; - match valueDecl.oval_prims with + (match valueDecl.oval_prims with | [] -> Doc.nil - | primitives -> Doc.indent ( - Doc.concat [ - Doc.text " ="; - Doc.line; - Doc.group ( - Doc.join ~sep:Doc.line (List.map (fun prim -> - let prim = if prim <> "" && (prim.[0] [@doesNotRaise]) = '\132' then "#rescript-external" else prim in - (* not display those garbage '\132' is a magic number for marshal *) - Doc.text ("\"" ^ prim ^ "\"")) primitives) - ) - ] - ) - ] - ) - | Osig_typext (outExtensionConstructor, _outExtStatus) -> - printOutExtensionConstructorDoc outExtensionConstructor - | Osig_modtype (modName, Omty_signature []) -> - Doc.concat [ - Doc.text "module type "; - Doc.text modName; - ] - | Osig_modtype (modName, outModuleType) -> - Doc.group ( - Doc.concat [ - Doc.text "module type "; - Doc.text modName; - Doc.text " = "; - printOutModuleTypeDoc outModuleType; - ] - ) - | Osig_module (modName, Omty_alias ident, _) -> - Doc.group ( - Doc.concat [ - Doc.text "module "; - Doc.text modName; - Doc.text " ="; - Doc.line; - printOutIdentDoc ident; - ] - ) - | Osig_module (modName, outModType, outRecStatus) -> - Doc.group ( - Doc.concat [ - Doc.text ( - match outRecStatus with - | Orec_not -> "module " - | Orec_first -> "module rec " - | Orec_next -> "and " - ); - Doc.text modName; - Doc.text ": "; - printOutModuleTypeDoc outModType; - ] - ) - | Osig_type (outTypeDecl, outRecStatus) -> - (* TODO: manifest ? *) - let attrs = match outTypeDecl.otype_immediate, outTypeDecl.otype_unboxed with - | false, false -> Doc.nil - | true, false -> - Doc.concat [Doc.text "@immediate"; Doc.line] - | false, true -> - Doc.concat [Doc.text "@unboxed"; Doc.line] - | true, true -> - Doc.concat [Doc.text "@immediate @unboxed"; Doc.line] - in - let kw = Doc.text ( - match outRecStatus with - | Orec_not -> "type " - | Orec_first -> "type rec " - | Orec_next -> "and " - ) in - let typeParams = match outTypeDecl.otype_params with - | [] -> Doc.nil - | _params -> Doc.group ( - Doc.concat [ - Doc.lessThan; - Doc.indent ( - Doc.concat [ + | primitives -> + Doc.indent + (Doc.concat + [ + Doc.text " ="; + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line + (List.map + (fun prim -> + let prim = + if + prim <> "" + && (prim.[0] [@doesNotRaise]) = '\132' + then "#rescript-external" + else prim + in + (* not display those garbage '\132' is a magic number for marshal *) + Doc.text ("\"" ^ prim ^ "\"")) + primitives)); + ])); + ]) + | Osig_typext (outExtensionConstructor, _outExtStatus) -> + printOutExtensionConstructorDoc outExtensionConstructor + | Osig_modtype (modName, Omty_signature []) -> + Doc.concat [Doc.text "module type "; Doc.text modName] + | Osig_modtype (modName, outModuleType) -> + Doc.group + (Doc.concat + [ + Doc.text "module type "; + Doc.text modName; + Doc.text " = "; + printOutModuleTypeDoc outModuleType; + ]) + | Osig_module (modName, Omty_alias ident, _) -> + Doc.group + (Doc.concat + [ + Doc.text "module "; + Doc.text modName; + Doc.text " ="; + Doc.line; + printOutIdentDoc ident; + ]) + | Osig_module (modName, outModType, outRecStatus) -> + Doc.group + (Doc.concat + [ + Doc.text + (match outRecStatus with + | Orec_not -> "module " + | Orec_first -> "module rec " + | Orec_next -> "and "); + Doc.text modName; + Doc.text ": "; + printOutModuleTypeDoc outModType; + ]) + | Osig_type (outTypeDecl, outRecStatus) -> + (* TODO: manifest ? *) + let attrs = + match (outTypeDecl.otype_immediate, outTypeDecl.otype_unboxed) with + | false, false -> Doc.nil + | true, false -> Doc.concat [Doc.text "@immediate"; Doc.line] + | false, true -> Doc.concat [Doc.text "@unboxed"; Doc.line] + | true, true -> Doc.concat [Doc.text "@immediate @unboxed"; Doc.line] + in + let kw = + Doc.text + (match outRecStatus with + | Orec_not -> "type " + | Orec_first -> "type rec " + | Orec_next -> "and ") + in + let typeParams = + match outTypeDecl.otype_params with + | [] -> Doc.nil + | _params -> + Doc.group + (Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map printTypeParameterDoc outTypeDecl.otype_params); + ]); + Doc.trailingComma; Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printTypeParameterDoc outTypeDecl.otype_params - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ] - ) - in - let privateDoc = match outTypeDecl.otype_private with - | Asttypes.Private -> Doc.text "private " - | Public -> Doc.nil - in - let kind = match outTypeDecl.otype_type with - | Otyp_open -> Doc.concat [ - Doc.text " = "; - privateDoc; - Doc.text ".."; - ] - | Otyp_abstract -> Doc.nil - | Otyp_record record -> Doc.concat [ - Doc.text " = "; - privateDoc; - printRecordDeclarationDoc ~inline:false record; - ] - | typ -> Doc.concat [ - Doc.text " = "; - printOutTypeDoc typ - ] - in - let constraints = match outTypeDecl.otype_cstrs with - | [] -> Doc.nil - | _ -> Doc.group ( - Doc.indent ( - Doc.concat [ - Doc.hardLine; - Doc.join ~sep:Doc.line (List.map (fun (typ1, typ2) -> - Doc.group ( - Doc.concat [ - Doc.text "constraint "; - printOutTypeDoc typ1; - Doc.text " ="; - Doc.space; - printOutTypeDoc typ2; - ] - ) - ) outTypeDecl.otype_cstrs) - ] - ) - ) in - Doc.group ( - Doc.concat [ - attrs; - Doc.group ( - Doc.concat [ - attrs; - kw; - printIdentLike ~allowUident:false outTypeDecl.otype_name; - typeParams; - kind - ] - ); - constraints - ] - ) + Doc.greaterThan; + ]) + in + let privateDoc = + match outTypeDecl.otype_private with + | Asttypes.Private -> Doc.text "private " + | Public -> Doc.nil + in + let kind = + match outTypeDecl.otype_type with + | Otyp_open -> Doc.concat [Doc.text " = "; privateDoc; Doc.text ".."] + | Otyp_abstract -> Doc.nil + | Otyp_record record -> + Doc.concat + [ + Doc.text " = "; + privateDoc; + printRecordDeclarationDoc ~inline:false record; + ] + | typ -> Doc.concat [Doc.text " = "; printOutTypeDoc typ] + in + let constraints = + match outTypeDecl.otype_cstrs with + | [] -> Doc.nil + | _ -> + Doc.group + (Doc.indent + (Doc.concat + [ + Doc.hardLine; + Doc.join ~sep:Doc.line + (List.map + (fun (typ1, typ2) -> + Doc.group + (Doc.concat + [ + Doc.text "constraint "; + printOutTypeDoc typ1; + Doc.text " ="; + Doc.space; + printOutTypeDoc typ2; + ])) + outTypeDecl.otype_cstrs); + ])) + in + Doc.group + (Doc.concat + [ + attrs; + Doc.group + (Doc.concat + [ + attrs; + kw; + printIdentLike ~allowUident:false outTypeDecl.otype_name; + typeParams; + kind; + ]); + constraints; + ]) - and printOutModuleTypeDoc (outModType : Outcometree.out_module_type) = - match outModType with - | Omty_abstract -> Doc.nil - | Omty_ident ident -> printOutIdentDoc ident - (* example: module Increment = (M: X_int) => X_int *) - | Omty_functor _ -> - let (args, returnModType) = collectFunctorArgs outModType [] in - let argsDoc = match args with - | [_, None] -> Doc.text "()" - | args -> - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun (lbl, optModType) -> Doc.group ( - Doc.concat [ - Doc.text lbl; - match optModType with - | None -> Doc.nil - | Some modType -> Doc.concat [ - Doc.text ": "; - printOutModuleTypeDoc modType; - ] - ] - )) args - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - in - Doc.group ( - Doc.concat [ - argsDoc; - Doc.text " => "; - printOutModuleTypeDoc returnModType - ] - ) - | Omty_signature [] -> Doc.nil - | Omty_signature signature -> - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ +and printOutModuleTypeDoc (outModType : Outcometree.out_module_type) = + match outModType with + | Omty_abstract -> Doc.nil + | Omty_ident ident -> printOutIdentDoc ident + (* example: module Increment = (M: X_int) => X_int *) + | Omty_functor _ -> + let args, returnModType = collectFunctorArgs outModType [] in + let argsDoc = + match args with + | [(_, None)] -> Doc.text "()" + | args -> + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun (lbl, optModType) -> + Doc.group + (Doc.concat + [ + Doc.text lbl; + (match optModType with + | None -> Doc.nil + | Some modType -> + Doc.concat + [ + Doc.text ": "; + printOutModuleTypeDoc modType; + ]); + ])) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) + in + Doc.group + (Doc.concat + [argsDoc; Doc.text " => "; printOutModuleTypeDoc returnModType]) + | Omty_signature [] -> Doc.nil + | Omty_signature signature -> + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.line; - printOutSignatureDoc signature; - ] - ); + Doc.indent (Doc.concat [Doc.line; printOutSignatureDoc signature]); Doc.softLine; Doc.rbrace; - ] - ) - | Omty_alias _ident -> Doc.nil - - and printOutSignatureDoc (signature : Outcometree.out_sig_item list) = - let rec loop signature acc = - match signature with - | [] -> List.rev acc - | Outcometree.Osig_typext(ext, Oext_first) :: items -> - (* Gather together the extension constructors *) - let rec gather_extensions acc items = - match items with - Outcometree.Osig_typext(ext, Oext_next) :: items -> - gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) - items - | _ -> (List.rev acc, items) - in - let exts, items = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] - items - in - let te = - { Outcometree.otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private } - in - let doc = printOutTypeExtensionDoc te in - loop items (doc::acc) - | item::items -> - let doc = printOutSigItemDoc item in - loop items (doc::acc) - in - match loop signature [] with - | [doc] -> doc - | docs -> - Doc.breakableGroup ~forceBreak:true ( - Doc.join ~sep:Doc.line docs - ) + ]) + | Omty_alias _ident -> Doc.nil - and printOutExtensionConstructorDoc (outExt : Outcometree.out_extension_constructor) = - let typeParams = match outExt.oext_type_params with - | [] -> Doc.nil - | params -> - Doc.group( - Doc.concat [ - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun ty -> Doc.text (if ty = "_" then ty else "'" ^ ty)) - params +and printOutSignatureDoc (signature : Outcometree.out_sig_item list) = + let rec loop signature acc = + match signature with + | [] -> List.rev acc + | Outcometree.Osig_typext (ext, Oext_first) :: items -> + (* Gather together the extension constructors *) + let rec gather_extensions acc items = + match items with + | Outcometree.Osig_typext (ext, Oext_next) :: items -> + gather_extensions + ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] + items + in + let te = + { + Outcometree.otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private; + } + in + let doc = printOutTypeExtensionDoc te in + loop items (doc :: acc) + | item :: items -> + let doc = printOutSigItemDoc item in + loop items (doc :: acc) + in + match loop signature [] with + | [doc] -> doc + | docs -> Doc.breakableGroup ~forceBreak:true (Doc.join ~sep:Doc.line docs) - ) - ] - ); - Doc.softLine; - Doc.greaterThan; - ] - ) +and printOutExtensionConstructorDoc + (outExt : Outcometree.out_extension_constructor) = + let typeParams = + match outExt.oext_type_params with + | [] -> Doc.nil + | params -> + Doc.group + (Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun ty -> + Doc.text (if ty = "_" then ty else "'" ^ ty)) + params); + ]); + Doc.softLine; + Doc.greaterThan; + ]) + in - in - Doc.group ( - Doc.concat [ + Doc.group + (Doc.concat + [ Doc.text "type "; printIdentLike ~allowUident:false outExt.oext_type_name; typeParams; Doc.text " += "; Doc.line; - if outExt.oext_private = Asttypes.Private then - Doc.text "private " - else - Doc.nil; + (if outExt.oext_private = Asttypes.Private then Doc.text "private " + else Doc.nil); printOutConstructorDoc - (outExt.oext_name, outExt.oext_args, outExt.oext_ret_type) - ] - ) + (outExt.oext_name, outExt.oext_args, outExt.oext_ret_type); + ]) - and printOutTypeExtensionDoc (typeExtension : Outcometree.out_type_extension) = - let typeParams = match typeExtension.otyext_params with - | [] -> Doc.nil - | params -> - Doc.group( - Doc.concat [ - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun ty -> Doc.text (if ty = "_" then ty else "'" ^ ty)) - params - - ) - ] - ); - Doc.softLine; - Doc.greaterThan; - ] - ) +and printOutTypeExtensionDoc (typeExtension : Outcometree.out_type_extension) = + let typeParams = + match typeExtension.otyext_params with + | [] -> Doc.nil + | params -> + Doc.group + (Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun ty -> + Doc.text (if ty = "_" then ty else "'" ^ ty)) + params); + ]); + Doc.softLine; + Doc.greaterThan; + ]) + in - in - Doc.group ( - Doc.concat [ + Doc.group + (Doc.concat + [ Doc.text "type "; printIdentLike ~allowUident:false typeExtension.otyext_name; typeParams; Doc.text " += "; - if typeExtension.otyext_private = Asttypes.Private then - Doc.text "private " - else - Doc.nil; + (if typeExtension.otyext_private = Asttypes.Private then + Doc.text "private " + else Doc.nil); printOutConstructorsDoc typeExtension.otyext_constructors; - ] - ) + ]) - let printOutSigItem fmt outSigItem = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutSigItemDoc outSigItem)) +let printOutSigItem fmt outSigItem = + Format.pp_print_string fmt + (Doc.toString ~width:80 (printOutSigItemDoc outSigItem)) - let printOutSignature fmt signature = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutSignatureDoc signature)) +let printOutSignature fmt signature = + Format.pp_print_string fmt + (Doc.toString ~width:80 (printOutSignatureDoc signature)) - let validFloatLexeme s = - let l = String.length s in - let rec loop i = - if i >= l then s ^ "." else - match (s.[i] [@doesNotRaise]) with - | '0' .. '9' | '-' -> loop (i+1) - | _ -> s - in loop 0 +let validFloatLexeme s = + let l = String.length s in + let rec loop i = + if i >= l then s ^ "." + else + match s.[i] [@doesNotRaise] with + | '0' .. '9' | '-' -> loop (i + 1) + | _ -> s + in + loop 0 - let floatRepres f = - match classify_float f with - | FP_nan -> "nan" - | FP_infinite -> - if f < 0.0 then "neg_infinity" else "infinity" - | _ -> - let float_val = - let s1 = Printf.sprintf "%.12g" f in - if f = (float_of_string [@doesNotRaise]) s1 then s1 else - let s2 = Printf.sprintf "%.15g" f in - if f = (float_of_string [@doesNotRaise]) s2 then s2 else - Printf.sprintf "%.18g" f - in validFloatLexeme float_val +let floatRepres f = + match classify_float f with + | FP_nan -> "nan" + | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" + | _ -> + let float_val = + let s1 = Printf.sprintf "%.12g" f in + if f = (float_of_string [@doesNotRaise]) s1 then s1 + else + let s2 = Printf.sprintf "%.15g" f in + if f = (float_of_string [@doesNotRaise]) s2 then s2 + else Printf.sprintf "%.18g" f + in + validFloatLexeme float_val - let rec printOutValueDoc (outValue : Outcometree.out_value) = - match outValue with - | Oval_array outValues -> - Doc.group ( - Doc.concat [ +let rec printOutValueDoc (outValue : Outcometree.out_value) = + match outValue with + | Oval_array outValues -> + Doc.group + (Doc.concat + [ Doc.lbracket; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutValueDoc outValues - ) - ] - ); + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map printOutValueDoc outValues); + ]); Doc.trailingComma; Doc.softLine; Doc.rbracket; - ] - ) - | Oval_char c -> Doc.text ("'" ^ (Char.escaped c) ^ "'") - | Oval_constr (outIdent, outValues) -> - Doc.group ( - Doc.concat [ + ]) + | Oval_char c -> Doc.text ("'" ^ Char.escaped c ^ "'") + | Oval_constr (outIdent, outValues) -> + Doc.group + (Doc.concat + [ printOutIdentDoc outIdent; Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutValueDoc outValues - ) - ] - ); + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map printOutValueDoc outValues); + ]); Doc.trailingComma; Doc.softLine; Doc.rparen; - ] - ) - | Oval_ellipsis -> Doc.text "..." - | Oval_int i -> Doc.text (Format.sprintf "%i" i) - | Oval_int32 i -> Doc.text (Format.sprintf "%lil" i) - | Oval_int64 i -> Doc.text (Format.sprintf "%LiL" i) - | Oval_nativeint i -> Doc.text (Format.sprintf "%nin" i) - | Oval_float f -> Doc.text (floatRepres f) - | Oval_list outValues -> - Doc.group ( - Doc.concat [ + ]) + | Oval_ellipsis -> Doc.text "..." + | Oval_int i -> Doc.text (Format.sprintf "%i" i) + | Oval_int32 i -> Doc.text (Format.sprintf "%lil" i) + | Oval_int64 i -> Doc.text (Format.sprintf "%LiL" i) + | Oval_nativeint i -> Doc.text (Format.sprintf "%nin" i) + | Oval_float f -> Doc.text (floatRepres f) + | Oval_list outValues -> + Doc.group + (Doc.concat + [ Doc.text "list["; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutValueDoc outValues - ) - ] - ); + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map printOutValueDoc outValues); + ]); Doc.trailingComma; Doc.softLine; Doc.rbracket; - ] - ) - | Oval_printer fn -> - let fmt = Format.str_formatter in - fn fmt; - let str = Format.flush_str_formatter () in - Doc.text str - | Oval_record rows -> - Doc.group ( - Doc.concat [ + ]) + | Oval_printer fn -> + let fmt = Format.str_formatter in + fn fmt; + let str = Format.flush_str_formatter () in + Doc.text str + | Oval_record rows -> + Doc.group + (Doc.concat + [ Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun (outIdent, outValue) -> Doc.group ( - Doc.concat [ - printOutIdentDoc outIdent; - Doc.text ": "; - printOutValueDoc outValue; - ] - ) - ) rows - ); - ] - ); + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun (outIdent, outValue) -> + Doc.group + (Doc.concat + [ + printOutIdentDoc outIdent; + Doc.text ": "; + printOutValueDoc outValue; + ])) + rows); + ]); Doc.trailingComma; Doc.softLine; Doc.rparen; - ] - ) - | Oval_string (txt, _sizeToPrint, _kind) -> - Doc.text (escapeStringContents txt) - | Oval_stuff txt -> Doc.text txt - | Oval_tuple outValues -> - Doc.group ( - Doc.concat [ + ]) + | Oval_string (txt, _sizeToPrint, _kind) -> + Doc.text (escapeStringContents txt) + | Oval_stuff txt -> Doc.text txt + | Oval_tuple outValues -> + Doc.group + (Doc.concat + [ Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutValueDoc outValues - ) - ] - ); + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map printOutValueDoc outValues); + ]); Doc.trailingComma; Doc.softLine; Doc.rparen; - ] - ) - (* Not supported by ReScript *) - | Oval_variant _ -> Doc.nil + ]) + (* Not supported by ReScript *) + | Oval_variant _ -> Doc.nil - let printOutExceptionDoc exc outValue = - match exc with - | Sys.Break -> Doc.text "Interrupted." - | Out_of_memory -> Doc.text "Out of memory during evaluation." - | Stack_overflow -> - Doc.text "Stack overflow during evaluation (looping recursion?)." - | _ -> - Doc.group ( - Doc.indent( - Doc.concat [ - Doc.text "Exception:"; - Doc.line; - printOutValueDoc outValue; - ] - ) - ) +let printOutExceptionDoc exc outValue = + match exc with + | Sys.Break -> Doc.text "Interrupted." + | Out_of_memory -> Doc.text "Out of memory during evaluation." + | Stack_overflow -> + Doc.text "Stack overflow during evaluation (looping recursion?)." + | _ -> + Doc.group + (Doc.indent + (Doc.concat + [Doc.text "Exception:"; Doc.line; printOutValueDoc outValue])) - let printOutPhraseSignature signature = - let rec loop signature acc = - match signature with - | [] -> List.rev acc - | (Outcometree.Osig_typext(ext, Oext_first), None)::signature -> - (* Gather together extension constructors *) - let rec gather_extensions acc items = - match items with - | (Outcometree.Osig_typext(ext, Oext_next), None)::items -> - gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type)::acc) - items - | _ -> (List.rev acc, items) - in - let exts, signature = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] - signature - in - let te = - { Outcometree.otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private } - in - let doc = printOutTypeExtensionDoc te in - loop signature (doc::acc) - | (sigItem, optOutValue)::signature -> - let doc = match optOutValue with - | None -> - printOutSigItemDoc sigItem - | Some outValue -> - Doc.group ( - Doc.concat [ - printOutSigItemDoc sigItem; - Doc.text " = "; - printOutValueDoc outValue; - ] - ) - in - loop signature (doc::acc) +let printOutPhraseSignature signature = + let rec loop signature acc = + match signature with + | [] -> List.rev acc + | (Outcometree.Osig_typext (ext, Oext_first), None) :: signature -> + (* Gather together extension constructors *) + let rec gather_extensions acc items = + match items with + | (Outcometree.Osig_typext (ext, Oext_next), None) :: items -> + gather_extensions + ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, signature = + gather_extensions + [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] + signature in - Doc.breakableGroup ~forceBreak:true ( - Doc.join ~sep:Doc.line (loop signature []) - ) + let te = + { + Outcometree.otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private; + } + in + let doc = printOutTypeExtensionDoc te in + loop signature (doc :: acc) + | (sigItem, optOutValue) :: signature -> + let doc = + match optOutValue with + | None -> printOutSigItemDoc sigItem + | Some outValue -> + Doc.group + (Doc.concat + [ + printOutSigItemDoc sigItem; + Doc.text " = "; + printOutValueDoc outValue; + ]) + in + loop signature (doc :: acc) + in + Doc.breakableGroup ~forceBreak:true + (Doc.join ~sep:Doc.line (loop signature [])) - let printOutPhraseDoc (outPhrase : Outcometree.out_phrase) = - match outPhrase with - | Ophr_eval (outValue, outType) -> - Doc.group ( - Doc.concat [ +let printOutPhraseDoc (outPhrase : Outcometree.out_phrase) = + match outPhrase with + | Ophr_eval (outValue, outType) -> + Doc.group + (Doc.concat + [ Doc.text "- : "; printOutTypeDoc outType; Doc.text " ="; - Doc.indent ( - Doc.concat [ - Doc.line; - printOutValueDoc outValue; - ] - ) - ] - ) - | Ophr_signature [] -> Doc.nil - | Ophr_signature signature -> printOutPhraseSignature signature - | Ophr_exception (exc, outValue) -> - printOutExceptionDoc exc outValue - - let printOutPhrase fmt outPhrase = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutPhraseDoc outPhrase)) - - let printOutModuleType fmt outModuleType = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutModuleTypeDoc outModuleType)) - - let printOutTypeExtension fmt typeExtension = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutTypeExtensionDoc typeExtension)) - - let printOutValue fmt outValue = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutValueDoc outValue)) + Doc.indent (Doc.concat [Doc.line; printOutValueDoc outValue]); + ]) + | Ophr_signature [] -> Doc.nil + | Ophr_signature signature -> printOutPhraseSignature signature + | Ophr_exception (exc, outValue) -> printOutExceptionDoc exc outValue +let printOutPhrase fmt outPhrase = + Format.pp_print_string fmt + (Doc.toString ~width:80 (printOutPhraseDoc outPhrase)) +let printOutModuleType fmt outModuleType = + Format.pp_print_string fmt + (Doc.toString ~width:80 (printOutModuleTypeDoc outModuleType)) +let printOutTypeExtension fmt typeExtension = + Format.pp_print_string fmt + (Doc.toString ~width:80 (printOutTypeExtensionDoc typeExtension)) +let printOutValue fmt outValue = + Format.pp_print_string fmt + (Doc.toString ~width:80 (printOutValueDoc outValue)) (* Not supported in ReScript *) (* Oprint.out_class_type *) - let setup = lazy begin - Oprint.out_value := printOutValue; - Oprint.out_type := printOutType; - Oprint.out_module_type := printOutModuleType; - Oprint.out_sig_item := printOutSigItem; - Oprint.out_signature := printOutSignature; - Oprint.out_type_extension := printOutTypeExtension; - Oprint.out_phrase := printOutPhrase - end - +let setup = + lazy + (Oprint.out_value := printOutValue; + Oprint.out_type := printOutType; + Oprint.out_module_type := printOutModuleType; + Oprint.out_sig_item := printOutSigItem; + Oprint.out_signature := printOutSignature; + Oprint.out_type_extension := printOutTypeExtension; + Oprint.out_phrase := printOutPhrase) diff --git a/src/res_parens.ml b/src/res_parens.ml index 5656a9d7..33fb0f3d 100644 --- a/src/res_parens.ml +++ b/src/res_parens.ml @@ -1,417 +1,414 @@ module ParsetreeViewer = Res_parsetree_viewer type kind = Parenthesized | Braced of Location.t | Nothing - let expr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | _ -> - begin match expr with - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_constraint _ } -> Parenthesized - | _ -> Nothing - end +let expr expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | _ -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_constraint _} -> Parenthesized + | _ -> Nothing) - let callExpr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | _ -> - begin match expr with - | {Parsetree.pexp_attributes = attrs} when - begin match ParsetreeViewer.filterParsingAttrs attrs with - | _::_ -> true - | [] -> false - end - -> Parenthesized - | _ when ParsetreeViewer.isUnaryExpression expr || ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_fun _} - when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing - | {pexp_desc = - Pexp_lazy _ - | Pexp_assert _ - | Pexp_fun _ - | Pexp_newtype _ - | Pexp_function _ - | Pexp_constraint _ - | Pexp_setfield _ - | Pexp_match _ - | Pexp_try _ - | Pexp_while _ - | Pexp_for _ - | Pexp_ifthenelse _ - } -> Parenthesized - | _ -> Nothing - end +let callExpr expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | _ -> ( + match expr with + | {Parsetree.pexp_attributes = attrs} + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | _ + when ParsetreeViewer.isUnaryExpression expr + || ParsetreeViewer.isBinaryExpression expr -> + Parenthesized + | { + Parsetree.pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr + -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ + | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ + | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ -> Nothing) - let structureExpr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | _ when ParsetreeViewer.hasAttributes expr.pexp_attributes && - not (ParsetreeViewer.isJsxExpression expr) -> Parenthesized - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_constraint _ } -> Parenthesized - | _ -> Nothing - end +let structureExpr expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | None -> ( + match expr with + | _ + when ParsetreeViewer.hasAttributes expr.pexp_attributes + && not (ParsetreeViewer.isJsxExpression expr) -> + Parenthesized + | { + Parsetree.pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_constraint _} -> Parenthesized + | _ -> Nothing) - let unaryExprOperand expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_attributes = attrs} when - begin match ParsetreeViewer.filterParsingAttrs attrs with - | _::_ -> true - | [] -> false - end - -> Parenthesized - | expr when - ParsetreeViewer.isUnaryExpression expr || - ParsetreeViewer.isBinaryExpression expr - -> Parenthesized - | {pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_fun _} - when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing - | {pexp_desc = - Pexp_lazy _ - | Pexp_assert _ - | Pexp_fun _ - | Pexp_newtype _ - | Pexp_function _ - | Pexp_constraint _ - | Pexp_setfield _ - | Pexp_extension _ (* readability? maybe remove *) - | Pexp_match _ - | Pexp_try _ - | Pexp_while _ - | Pexp_for _ - | Pexp_ifthenelse _ - } -> Parenthesized - | _ -> Nothing - end +let unaryExprOperand expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | None -> ( + match expr with + | {Parsetree.pexp_attributes = attrs} + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | expr + when ParsetreeViewer.isUnaryExpression expr + || ParsetreeViewer.isBinaryExpression expr -> + Parenthesized + | { + pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr + -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ + | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ + | Pexp_extension _ (* readability? maybe remove *) | Pexp_match _ + | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ -> Nothing) - let binaryExprOperand ~isLhs expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_fun _} - when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing - | {pexp_desc = Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _} -> Parenthesized - | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized - | {pexp_desc = - Pexp_lazy _ - | Pexp_assert _ - } when isLhs -> Parenthesized - | {Parsetree.pexp_attributes = attrs} -> - if ParsetreeViewer.hasPrintableAttributes attrs then Parenthesized else Nothing - end +let binaryExprOperand ~isLhs expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | None -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr + -> + Nothing + | { + pexp_desc = + Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _; + } -> + Parenthesized + | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized + | {pexp_desc = Pexp_lazy _ | Pexp_assert _} when isLhs -> Parenthesized + | {Parsetree.pexp_attributes = attrs} -> + if ParsetreeViewer.hasPrintableAttributes attrs then Parenthesized + else Nothing) - let subBinaryExprOperand parentOperator childOperator = - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence childOperator in - precParent > precChild || - (precParent == precChild && - not (ParsetreeViewer.flattenableOperators parentOperator childOperator)) || - (* a && b || c, add parens to (a && b) for readability, who knows the difference by heart… *) - (parentOperator = "||" && childOperator = "&&") +let subBinaryExprOperand parentOperator childOperator = + let precParent = ParsetreeViewer.operatorPrecedence parentOperator in + let precChild = ParsetreeViewer.operatorPrecedence childOperator in + precParent > precChild + || precParent == precChild + && not (ParsetreeViewer.flattenableOperators parentOperator childOperator) + || (* a && b || c, add parens to (a && b) for readability, who knows the difference by heart… *) + (parentOperator = "||" && childOperator = "&&") - let rhsBinaryExprOperand parentOperator rhs = - match rhs.Parsetree.pexp_desc with - | Parsetree.Pexp_apply( - {pexp_attributes = []; - pexp_desc = Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}}, - [_, _left; _, _right] - ) when ParsetreeViewer.isBinaryOperator operator && - not (operatorLoc.loc_ghost && operator = "^") -> +let rhsBinaryExprOperand parentOperator rhs = + match rhs.Parsetree.pexp_desc with + | Parsetree.Pexp_apply + ( { + pexp_attributes = []; + pexp_desc = + Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; + }, + [(_, _left); (_, _right)] ) + when ParsetreeViewer.isBinaryOperator operator + && not (operatorLoc.loc_ghost && operator = "^") -> let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence operator in + let precChild = ParsetreeViewer.operatorPrecedence operator in precParent == precChild - | _ -> false - - let flattenOperandRhs parentOperator rhs = - match rhs.Parsetree.pexp_desc with - | Parsetree.Pexp_apply( - {pexp_desc = Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}}, - [_, _left; _, _right] - ) when ParsetreeViewer.isBinaryOperator operator && - not (operatorLoc.loc_ghost && operator = "^") -> - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence operator in - precParent >= precChild || rhs.pexp_attributes <> [] - | Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - ) -> false - | Pexp_fun _ when ParsetreeViewer.isUnderscoreApplySugar rhs -> false - | Pexp_fun _ - | Pexp_newtype _ - | Pexp_setfield _ - | Pexp_constraint _ -> true - | _ when ParsetreeViewer.isTernaryExpr rhs -> true - | _ -> false + | _ -> false - let lazyOrAssertExprRhs expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_attributes = attrs} when - begin match ParsetreeViewer.filterParsingAttrs attrs with - | _::_ -> true - | [] -> false - end - -> Parenthesized - | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | {pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_fun _} - when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing - | {pexp_desc = - Pexp_lazy _ - | Pexp_assert _ - | Pexp_fun _ - | Pexp_newtype _ - | Pexp_function _ - | Pexp_constraint _ - | Pexp_setfield _ - | Pexp_match _ - | Pexp_try _ - | Pexp_while _ - | Pexp_for _ - | Pexp_ifthenelse _ - } -> Parenthesized - | _ -> Nothing - end +let flattenOperandRhs parentOperator rhs = + match rhs.Parsetree.pexp_desc with + | Parsetree.Pexp_apply + ( { + pexp_desc = + Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; + }, + [(_, _left); (_, _right)] ) + when ParsetreeViewer.isBinaryOperator operator + && not (operatorLoc.loc_ghost && operator = "^") -> + let precParent = ParsetreeViewer.operatorPrecedence parentOperator in + let precChild = ParsetreeViewer.operatorPrecedence operator in + precParent >= precChild || rhs.pexp_attributes <> [] + | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> + false + | Pexp_fun _ when ParsetreeViewer.isUnderscoreApplySugar rhs -> false + | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_constraint _ -> true + | _ when ParsetreeViewer.isTernaryExpr rhs -> true + | _ -> false - let isNegativeConstant constant = - let isNeg txt = - let len = String.length txt in - len > 0 && (String.get [@doesNotRaise]) txt 0 = '-' - in - match constant with - | Parsetree.Pconst_integer (i, _) | Pconst_float (i, _) when isNeg i -> true - | _ -> false +let lazyOrAssertExprRhs expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | None -> ( + match expr with + | {Parsetree.pexp_attributes = attrs} + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | { + pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr + -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ + | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ + | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ -> Nothing) - let fieldExpr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_attributes = attrs} when - begin match ParsetreeViewer.filterParsingAttrs attrs with - | _::_ -> true - | [] -> false - end - -> Parenthesized - | expr when - ParsetreeViewer.isBinaryExpression expr || - ParsetreeViewer.isUnaryExpression expr - -> Parenthesized - | {pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_constant c } when isNegativeConstant c -> Parenthesized - | {pexp_desc = Pexp_fun _} - when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing - | {pexp_desc = - Pexp_lazy _ - | Pexp_assert _ - | Pexp_extension _ (* %extension.x vs (%extension).x *) - | Pexp_fun _ - | Pexp_newtype _ - | Pexp_function _ - | Pexp_constraint _ - | Pexp_setfield _ - | Pexp_match _ - | Pexp_try _ - | Pexp_while _ - | Pexp_for _ - | Pexp_ifthenelse _ - } -> Parenthesized - | _ -> Nothing - end +let isNegativeConstant constant = + let isNeg txt = + let len = String.length txt in + len > 0 && (String.get [@doesNotRaise]) txt 0 = '-' + in + match constant with + | (Parsetree.Pconst_integer (i, _) | Pconst_float (i, _)) when isNeg i -> true + | _ -> false - let setFieldExprRhs expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_constraint _ } -> Parenthesized - | _ -> Nothing - end +let fieldExpr expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | None -> ( + match expr with + | {Parsetree.pexp_attributes = attrs} + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | expr + when ParsetreeViewer.isBinaryExpression expr + || ParsetreeViewer.isUnaryExpression expr -> + Parenthesized + | { + pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_constant c} when isNegativeConstant c -> Parenthesized + | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr + -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ + | Pexp_extension _ (* %extension.x vs (%extension).x *) | Pexp_fun _ + | Pexp_newtype _ | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ + | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ + | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ -> Nothing) - let ternaryOperand expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_constraint _ } -> Parenthesized - | {pexp_desc = Pexp_fun _ | Pexp_newtype _} -> - let (_attrsOnArrow, _parameters, returnExpr) = ParsetreeViewer.funExpr expr in - begin match returnExpr.pexp_desc with - | Pexp_constraint _ -> Parenthesized - | _ -> Nothing - end - | _ -> Nothing - end +let setFieldExprRhs expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | None -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_constraint _} -> Parenthesized + | _ -> Nothing) - let startsWithMinus txt = - let len = String.length txt in - if len == 0 then - false - else - let s = (String.get [@doesNotRaise]) txt 0 in - s = '-' +let ternaryOperand expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | None -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_constraint _} -> Parenthesized + | {pexp_desc = Pexp_fun _ | Pexp_newtype _} -> ( + let _attrsOnArrow, _parameters, returnExpr = + ParsetreeViewer.funExpr expr + in + match returnExpr.pexp_desc with + | Pexp_constraint _ -> Parenthesized + | _ -> Nothing) + | _ -> Nothing) - let jsxPropExpr expr = - match expr.Parsetree.pexp_desc with - | Parsetree.Pexp_let _ - | Pexp_sequence _ - | Pexp_letexception _ - | Pexp_letmodule _ - | Pexp_open _ -> Nothing - | _ -> - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - begin match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_desc = - Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); - pexp_attributes = []} - when startsWithMinus x -> Parenthesized - | {Parsetree.pexp_desc = - Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ | Pexp_variant _ | - Pexp_array _ | Pexp_pack _ | Pexp_record _ | Pexp_extension _ | - Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ | - Pexp_let _ | Pexp_tuple _; - pexp_attributes = [] - } -> Nothing - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - ); pexp_attributes = []} -> Nothing - | _ -> Parenthesized - end - end +let startsWithMinus txt = + let len = String.length txt in + if len == 0 then false + else + let s = (String.get [@doesNotRaise]) txt 0 in + s = '-' - let jsxChildExpr expr = - match expr.Parsetree.pexp_desc with - | Parsetree.Pexp_let _ - | Pexp_sequence _ - | Pexp_letexception _ - | Pexp_letmodule _ - | Pexp_open _ -> Nothing - | _ -> - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - begin match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | _ -> - begin match expr with - | {Parsetree.pexp_desc = Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); - pexp_attributes = [] - } when startsWithMinus x -> Parenthesized - | {Parsetree.pexp_desc = - Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ | Pexp_variant _ | - Pexp_array _ | Pexp_pack _ | Pexp_record _ | Pexp_extension _ | - Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ | - Pexp_let _; - pexp_attributes = [] - } -> Nothing - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - ); pexp_attributes = []} -> Nothing - | expr when ParsetreeViewer.isJsxExpression expr -> Nothing - | _ -> Parenthesized - end - end +let jsxPropExpr expr = + match expr.Parsetree.pexp_desc with + | Parsetree.Pexp_let _ | Pexp_sequence _ | Pexp_letexception _ + | Pexp_letmodule _ | Pexp_open _ -> + Nothing + | _ -> ( + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | None -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); + pexp_attributes = []; + } + when startsWithMinus x -> + Parenthesized + | { + Parsetree.pexp_desc = + ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ + | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ + | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ + | Pexp_open _ | Pexp_sequence _ | Pexp_let _ | Pexp_tuple _ ); + pexp_attributes = []; + } -> + Nothing + | { + Parsetree.pexp_desc = + Pexp_constraint + ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + pexp_attributes = []; + } -> + Nothing + | _ -> Parenthesized)) - let binaryExpr expr = +let jsxChildExpr expr = + match expr.Parsetree.pexp_desc with + | Parsetree.Pexp_let _ | Pexp_sequence _ | Pexp_letexception _ + | Pexp_letmodule _ | Pexp_open _ -> + Nothing + | _ -> ( let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_attributes = _::_} as expr - when ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | _ -> Nothing - end + | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | _ -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); + pexp_attributes = []; + } + when startsWithMinus x -> + Parenthesized + | { + Parsetree.pexp_desc = + ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ + | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ + | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ + | Pexp_open _ | Pexp_sequence _ | Pexp_let _ ); + pexp_attributes = []; + } -> + Nothing + | { + Parsetree.pexp_desc = + Pexp_constraint + ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + pexp_attributes = []; + } -> + Nothing + | expr when ParsetreeViewer.isJsxExpression expr -> Nothing + | _ -> Parenthesized)) + +let binaryExpr expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | None -> ( + match expr with + | {Parsetree.pexp_attributes = _ :: _} as expr + when ParsetreeViewer.isBinaryExpression expr -> + Parenthesized + | _ -> Nothing) - let modTypeFunctorReturn modType = match modType with - | {Parsetree.pmty_desc = Pmty_with _} -> true - | _ -> false +let modTypeFunctorReturn modType = + match modType with + | {Parsetree.pmty_desc = Pmty_with _} -> true + | _ -> false - (* Add parens for readability: - module type Functor = SetLike => Set with type t = A.t - This is actually: - module type Functor = (SetLike => Set) with type t = A.t - *) - let modTypeWithOperand modType = match modType with - | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true - | _ -> false +(* Add parens for readability: + module type Functor = SetLike => Set with type t = A.t + This is actually: + module type Functor = (SetLike => Set) with type t = A.t +*) +let modTypeWithOperand modType = + match modType with + | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true + | _ -> false - let modExprFunctorConstraint modType = match modType with - | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true - | _ -> false +let modExprFunctorConstraint modType = + match modType with + | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true + | _ -> false - let bracedExpr expr = match expr.Parsetree.pexp_desc with - | Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - ) -> false - | Pexp_constraint _ -> true - | _ -> false +let bracedExpr expr = + match expr.Parsetree.pexp_desc with + | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> + false + | Pexp_constraint _ -> true + | _ -> false - let includeModExpr modExpr = match modExpr.Parsetree.pmod_desc with +let includeModExpr modExpr = + match modExpr.Parsetree.pmod_desc with | Parsetree.Pmod_constraint _ -> true | _ -> false -let arrowReturnTypExpr typExpr = match typExpr.Parsetree.ptyp_desc with +let arrowReturnTypExpr typExpr = + match typExpr.Parsetree.ptyp_desc with | Parsetree.Ptyp_arrow _ -> true | _ -> false let patternRecordRowRhs (pattern : Parsetree.pattern) = match pattern.ppat_desc with - | Ppat_constraint ({ppat_desc = Ppat_unpack _}, {ptyp_desc = Ptyp_package _}) -> false + | Ppat_constraint ({ppat_desc = Ppat_unpack _}, {ptyp_desc = Ptyp_package _}) + -> + false | Ppat_constraint _ -> true | _ -> false diff --git a/src/res_parens.mli b/src/res_parens.mli index 095b5630..04cca4b8 100644 --- a/src/res_parens.mli +++ b/src/res_parens.mli @@ -1,36 +1,36 @@ type kind = Parenthesized | Braced of Location.t | Nothing -val expr: Parsetree.expression -> kind -val structureExpr: Parsetree.expression -> kind +val expr : Parsetree.expression -> kind +val structureExpr : Parsetree.expression -> kind -val unaryExprOperand: Parsetree.expression -> kind +val unaryExprOperand : Parsetree.expression -> kind -val binaryExprOperand: isLhs:bool -> Parsetree.expression -> kind -val subBinaryExprOperand: string -> string -> bool -val rhsBinaryExprOperand: string -> Parsetree.expression -> bool -val flattenOperandRhs: string -> Parsetree.expression -> bool +val binaryExprOperand : isLhs:bool -> Parsetree.expression -> kind +val subBinaryExprOperand : string -> string -> bool +val rhsBinaryExprOperand : string -> Parsetree.expression -> bool +val flattenOperandRhs : string -> Parsetree.expression -> bool -val lazyOrAssertExprRhs: Parsetree.expression -> kind +val lazyOrAssertExprRhs : Parsetree.expression -> kind -val fieldExpr: Parsetree.expression -> kind +val fieldExpr : Parsetree.expression -> kind -val setFieldExprRhs: Parsetree.expression -> kind +val setFieldExprRhs : Parsetree.expression -> kind -val ternaryOperand: Parsetree.expression -> kind +val ternaryOperand : Parsetree.expression -> kind -val jsxPropExpr: Parsetree.expression -> kind -val jsxChildExpr: Parsetree.expression -> kind +val jsxPropExpr : Parsetree.expression -> kind +val jsxChildExpr : Parsetree.expression -> kind -val binaryExpr: Parsetree.expression -> kind -val modTypeFunctorReturn: Parsetree.module_type -> bool -val modTypeWithOperand: Parsetree.module_type -> bool -val modExprFunctorConstraint: Parsetree.module_type -> bool +val binaryExpr : Parsetree.expression -> kind +val modTypeFunctorReturn : Parsetree.module_type -> bool +val modTypeWithOperand : Parsetree.module_type -> bool +val modExprFunctorConstraint : Parsetree.module_type -> bool -val bracedExpr: Parsetree.expression -> bool -val callExpr: Parsetree.expression -> kind +val bracedExpr : Parsetree.expression -> bool +val callExpr : Parsetree.expression -> kind val includeModExpr : Parsetree.module_expr -> bool -val arrowReturnTypExpr: Parsetree.core_type -> bool +val arrowReturnTypExpr : Parsetree.core_type -> bool -val patternRecordRowRhs: Parsetree.pattern -> bool +val patternRecordRowRhs : Parsetree.pattern -> bool diff --git a/src/res_parser.mli b/src/res_parser.mli index 5f215ea6..09b0b455 100644 --- a/src/res_parser.mli +++ b/src/res_parser.mli @@ -23,27 +23,25 @@ type t = { mutable regions: regionStatus ref list; } -val make: ?mode:mode -> string -> string -> t - -val expect: ?grammar:Grammar.t -> Token.t -> t -> unit -val optional: t -> Token.t -> bool -val next: ?prevEndPos:Lexing.position -> t -> unit -val nextUnsafe: t -> unit (* Does not assert on Eof, makes no progress *) -val nextTemplateLiteralToken: t -> unit -val lookahead: t -> (t -> 'a) -> 'a -val err: +val make : ?mode:mode -> string -> string -> t + +val expect : ?grammar:Grammar.t -> Token.t -> t -> unit +val optional : t -> Token.t -> bool +val next : ?prevEndPos:Lexing.position -> t -> unit +val nextUnsafe : t -> unit (* Does not assert on Eof, makes no progress *) +val nextTemplateLiteralToken : t -> unit +val lookahead : t -> (t -> 'a) -> 'a +val err : ?startPos:Lexing.position -> ?endPos:Lexing.position -> - t -> Diagnostics.category -> unit + t -> + Diagnostics.category -> + unit -val leaveBreadcrumb: t -> Grammar.t -> unit -val eatBreadcrumb: t -> unit +val leaveBreadcrumb : t -> Grammar.t -> unit +val eatBreadcrumb : t -> unit -val beginRegion: t -> unit -val endRegion: t -> unit +val beginRegion : t -> unit +val endRegion : t -> unit -val checkProgress: - prevEndPos: Lexing.position -> - result: 'a -> - t -> - 'a option +val checkProgress : prevEndPos:Lexing.position -> result:'a -> t -> 'a option diff --git a/src/res_parsetree_viewer.ml b/src/res_parsetree_viewer.ml index d310902a..0c22f974 100644 --- a/src/res_parsetree_viewer.ml +++ b/src/res_parsetree_viewer.ml @@ -1,35 +1,48 @@ open Parsetree let arrowType ct = - let rec process attrsBefore acc typ = match typ with - | {ptyp_desc = Ptyp_arrow (Nolabel as lbl, typ1, typ2); ptyp_attributes = []} -> - let arg = ([], lbl, typ1) in - process attrsBefore (arg::acc) typ2 - | {ptyp_desc = Ptyp_arrow (Nolabel as lbl, typ1, typ2); ptyp_attributes = [({txt ="bs"}, _) ] as attrs} -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg::acc) typ2 - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} as returnType -> - let args = List.rev acc in - (attrsBefore, args, returnType) - | {ptyp_desc = Ptyp_arrow ((Labelled _ | Optional _) as lbl, typ1, typ2); ptyp_attributes = attrs} -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg::acc) typ2 - | typ -> - (attrsBefore, List.rev acc, typ) + let rec process attrsBefore acc typ = + match typ with + | { + ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); + ptyp_attributes = []; + } -> + let arg = ([], lbl, typ1) in + process attrsBefore (arg :: acc) typ2 + | { + ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); + ptyp_attributes = [({txt = "bs"}, _)] as attrs; + } -> + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg :: acc) typ2 + | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} + as returnType -> + let args = List.rev acc in + (attrsBefore, args, returnType) + | { + ptyp_desc = Ptyp_arrow (((Labelled _ | Optional _) as lbl), typ1, typ2); + ptyp_attributes = attrs; + } -> + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg :: acc) typ2 + | typ -> (attrsBefore, List.rev acc, typ) in - begin match ct with - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as typ -> + match ct with + | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as + typ -> process attrs [] {typ with ptyp_attributes = []} | typ -> process [] [] typ - end let functorType modtype = - let rec process acc modtype = match modtype with - | {pmty_desc = Pmty_functor (lbl, argType, returnType); pmty_attributes = attrs} -> - let arg = (attrs, lbl, argType) in - process (arg::acc) returnType - | modType -> - (List.rev acc, modType) + let rec process acc modtype = + match modtype with + | { + pmty_desc = Pmty_functor (lbl, argType, returnType); + pmty_attributes = attrs; + } -> + let arg = (attrs, lbl, argType) in + process (arg :: acc) returnType + | modType -> (List.rev acc, modType) in process [] modtype @@ -37,44 +50,47 @@ let processUncurriedAttribute attrs = let rec process uncurriedSpotted acc attrs = match attrs with | [] -> (uncurriedSpotted, List.rev acc) - | ({Location.txt = "bs"}, _)::rest -> process true acc rest - | attr::rest -> process uncurriedSpotted (attr::acc) rest + | ({Location.txt = "bs"}, _) :: rest -> process true acc rest + | attr :: rest -> process uncurriedSpotted (attr :: acc) rest in process false [] attrs let collectListExpressions expr = - let rec collect acc expr = match expr.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> - (List.rev acc, None) - | Pexp_construct ( - {txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple (hd::[tail])} - ) -> - collect (hd::acc) tail - | _ -> - (List.rev acc, Some expr) + let rec collect acc expr = + match expr.pexp_desc with + | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> (List.rev acc, None) + | Pexp_construct + ( {txt = Longident.Lident "::"}, + Some {pexp_desc = Pexp_tuple (hd :: [tail])} ) -> + collect (hd :: acc) tail + | _ -> (List.rev acc, Some expr) in collect [] expr (* (__x) => f(a, __x, c) -----> f(a, _, c) *) let rewriteUnderscoreApply expr = match expr.pexp_desc with - | Pexp_fun ( - Nolabel, - None, - {ppat_desc = Ppat_var {txt="__x"}}, - ({pexp_desc = Pexp_apply (callExpr, args)} as e) - ) -> - let newArgs = List.map (fun arg -> - match arg with - | ( - lbl, - ({pexp_desc = Pexp_ident ({txt = Longident.Lident "__x"} as lid)} as argExpr) - ) -> - (lbl, {argExpr with pexp_desc = Pexp_ident ({lid with txt = Longident.Lident "_"})}) - | arg -> arg - ) args in - {e with pexp_desc = Pexp_apply (callExpr, newArgs)} + | Pexp_fun + ( Nolabel, + None, + {ppat_desc = Ppat_var {txt = "__x"}}, + ({pexp_desc = Pexp_apply (callExpr, args)} as e) ) -> + let newArgs = + List.map + (fun arg -> + match arg with + | ( lbl, + ({pexp_desc = Pexp_ident ({txt = Longident.Lident "__x"} as lid)} + as argExpr) ) -> + ( lbl, + { + argExpr with + pexp_desc = Pexp_ident {lid with txt = Longident.Lident "_"}; + } ) + | arg -> arg) + args + in + {e with pexp_desc = Pexp_apply (callExpr, newArgs)} | _ -> expr type funParamKind = @@ -90,111 +106,109 @@ let funExpr expr = (* Turns (type t, type u, type z) into "type t u z" *) let rec collectNewTypes acc returnExpr = match returnExpr with - | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} -> - collectNewTypes (stringLoc::acc) returnExpr - | returnExpr -> - (List.rev acc, returnExpr) + | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} + -> + collectNewTypes (stringLoc :: acc) returnExpr + | returnExpr -> (List.rev acc, returnExpr) in - let rec collect attrsBefore acc expr = match expr with - | {pexp_desc = Pexp_fun ( - Nolabel, - None, - {ppat_desc = Ppat_var {txt="__x"}}, - {pexp_desc = Pexp_apply _} - )} -> - (attrsBefore, List.rev acc, rewriteUnderscoreApply expr) - | {pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = []} -> - let parameter = Parameter { - attrs = []; - lbl = lbl; - defaultExpr = defaultExpr; - pat = pattern; - } in - collect attrsBefore (parameter::acc) returnExpr - | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> - let (stringLocs, returnExpr) = collectNewTypes [stringLoc] rest in - let param = NewTypes {attrs; locs = stringLocs} in - collect attrsBefore (param::acc) returnExpr - | {pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = [({txt = "bs"}, _)] as attrs} -> - let parameter = Parameter { - attrs = attrs; - lbl = lbl; - defaultExpr = defaultExpr; - pat = pattern; - } in - collect attrsBefore (parameter::acc) returnExpr - | { - pexp_desc = Pexp_fun ((Labelled _ | Optional _) as lbl, defaultExpr, pattern, returnExpr); - pexp_attributes = attrs + let rec collect attrsBefore acc expr = + match expr with + | { + pexp_desc = + Pexp_fun + ( Nolabel, + None, + {ppat_desc = Ppat_var {txt = "__x"}}, + {pexp_desc = Pexp_apply _} ); } -> - let parameter = Parameter { - attrs = attrs; - lbl = lbl; - defaultExpr = defaultExpr; - pat = pattern; - } in - collect attrsBefore (parameter::acc) returnExpr - | expr -> - (attrsBefore, List.rev acc, expr) + (attrsBefore, List.rev acc, rewriteUnderscoreApply expr) + | { + pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); + pexp_attributes = []; + } -> + let parameter = Parameter {attrs = []; lbl; defaultExpr; pat = pattern} in + collect attrsBefore (parameter :: acc) returnExpr + | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> + let stringLocs, returnExpr = collectNewTypes [stringLoc] rest in + let param = NewTypes {attrs; locs = stringLocs} in + collect attrsBefore (param :: acc) returnExpr + | { + pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); + pexp_attributes = [({txt = "bs"}, _)] as attrs; + } -> + let parameter = Parameter {attrs; lbl; defaultExpr; pat = pattern} in + collect attrsBefore (parameter :: acc) returnExpr + | { + pexp_desc = + Pexp_fun + (((Labelled _ | Optional _) as lbl), defaultExpr, pattern, returnExpr); + pexp_attributes = attrs; + } -> + let parameter = Parameter {attrs; lbl; defaultExpr; pat = pattern} in + collect attrsBefore (parameter :: acc) returnExpr + | expr -> (attrsBefore, List.rev acc, expr) in - begin match expr with - | {pexp_desc = Pexp_fun (Nolabel, _defaultExpr, _pattern, _returnExpr); pexp_attributes = attrs} as expr -> + match expr with + | { + pexp_desc = Pexp_fun (Nolabel, _defaultExpr, _pattern, _returnExpr); + pexp_attributes = attrs; + } as expr -> collect attrs [] {expr with pexp_attributes = []} | expr -> collect [] [] expr - end let processBracesAttr expr = match expr.pexp_attributes with - | (({txt = "ns.braces"}, _) as attr)::attrs -> + | (({txt = "ns.braces"}, _) as attr) :: attrs -> (Some attr, {expr with pexp_attributes = attrs}) - | _ -> - (None, expr) + | _ -> (None, expr) let filterParsingAttrs attrs = - List.filter (fun attr -> - match attr with - | ({Location.txt = ("ns.ternary" | "ns.braces" | "res.template" | "bs" | "ns.iflet" | "ns.namedArgLoc")}, _) -> false - | _ -> true - ) attrs + List.filter + (fun attr -> + match attr with + | ( { + Location.txt = + ( "ns.ternary" | "ns.braces" | "res.template" | "bs" | "ns.iflet" + | "ns.namedArgLoc" ); + }, + _ ) -> + false + | _ -> true) + attrs let isBlockExpr expr = match expr.pexp_desc with - | Pexp_letmodule _ - | Pexp_letexception _ - | Pexp_let _ - | Pexp_open _ - | Pexp_sequence _ -> true + | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ + | Pexp_sequence _ -> + true | _ -> false let isBracedExpr expr = match processBracesAttr expr with - | (Some _, _) -> true + | Some _, _ -> true | _ -> false let isMultilineText txt = let len = String.length txt in - let rec check i= + let rec check i = if i >= len then false else let c = String.unsafe_get txt i in match c with | '\010' | '\013' -> true - | '\\' -> - if (i + 2) = len then false - else - check (i + 2) + | '\\' -> if i + 2 = len then false else check (i + 2) | _ -> check (i + 1) in check 0 let isHuggableExpression expr = match expr.pexp_desc with - | Pexp_array _ - | Pexp_tuple _ + | Pexp_array _ | Pexp_tuple _ | Pexp_constant (Pconst_string (_, Some _)) | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) | Pexp_extension ({txt = "bs.obj" | "obj"}, _) - | Pexp_record _ -> true + | Pexp_record _ -> + true | _ when isBlockExpr expr -> true | _ when isBracedExpr expr -> true | Pexp_constant (Pconst_string (txt, None)) when isMultilineText txt -> true @@ -202,24 +216,23 @@ let isHuggableExpression expr = let isHuggableRhs expr = match expr.pexp_desc with - | Pexp_array _ - | Pexp_tuple _ + | Pexp_array _ | Pexp_tuple _ | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) | Pexp_extension ({txt = "bs.obj" | "obj"}, _) - | Pexp_record _ -> true + | Pexp_record _ -> + true | _ when isBracedExpr expr -> true | _ -> false let isHuggablePattern pattern = match pattern.ppat_desc with - | Ppat_array _ - | Ppat_tuple _ - | Ppat_record _ - | Ppat_variant _ - | Ppat_construct _ -> true + | Ppat_array _ | Ppat_tuple _ | Ppat_record _ | Ppat_variant _ + | Ppat_construct _ -> + true | _ -> false -let operatorPrecedence operator = match operator with +let operatorPrecedence operator = + match operator with | ":=" -> 1 | "||" -> 2 | "&&" -> 3 @@ -230,297 +243,333 @@ let operatorPrecedence operator = match operator with | "#" | "##" | "|." -> 8 | _ -> 0 -let isUnaryOperator operator = match operator with +let isUnaryOperator operator = + match operator with | "~+" | "~+." | "~-" | "~-." | "not" -> true | _ -> false -let isUnaryExpression expr = match expr.pexp_desc with - | Pexp_apply( - {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [Nolabel, _arg] - ) when isUnaryOperator operator -> true +let isUnaryExpression expr = + match expr.pexp_desc with + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [(Nolabel, _arg)] ) + when isUnaryOperator operator -> + true | _ -> false (* TODO: tweak this to check for ghost ^ as template literal *) -let isBinaryOperator operator = match operator with - | ":=" - | "||" - | "&&" - | "=" | "==" | "<" | ">" | "!=" | "!==" | "<=" | ">=" | "|>" - | "+" | "+." | "-" | "-." | "^" - | "*" | "*." | "/" | "/." - | "**" - | "|." | "<>" -> true +let isBinaryOperator operator = + match operator with + | ":=" | "||" | "&&" | "=" | "==" | "<" | ">" | "!=" | "!==" | "<=" | ">=" + | "|>" | "+" | "+." | "-" | "-." | "^" | "*" | "*." | "/" | "/." | "**" | "|." + | "<>" -> + true | _ -> false -let isBinaryExpression expr = match expr.pexp_desc with - | Pexp_apply( - {pexp_desc = Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}}, - [(Nolabel, _operand1); (Nolabel, _operand2)] - ) when isBinaryOperator operator && - not (operatorLoc.loc_ghost && operator = "^") (* template literal *) - -> true +let isBinaryExpression expr = + match expr.pexp_desc with + | Pexp_apply + ( { + pexp_desc = + Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; + }, + [(Nolabel, _operand1); (Nolabel, _operand2)] ) + when isBinaryOperator operator + && not (operatorLoc.loc_ghost && operator = "^") + (* template literal *) -> + true | _ -> false -let isEqualityOperator operator = match operator with +let isEqualityOperator operator = + match operator with | "=" | "==" | "<>" | "!=" -> true | _ -> false let flattenableOperators parentOperator childOperator = let precParent = operatorPrecedence parentOperator in - let precChild = operatorPrecedence childOperator in + let precChild = operatorPrecedence childOperator in if precParent == precChild then - not ( - isEqualityOperator parentOperator && - isEqualityOperator childOperator - ) - else - false + not (isEqualityOperator parentOperator && isEqualityOperator childOperator) + else false let rec hasIfLetAttribute attrs = match attrs with | [] -> false - | ({Location.txt="ns.iflet"},_)::_ -> true - | _::attrs -> hasIfLetAttribute attrs + | ({Location.txt = "ns.iflet"}, _) :: _ -> true + | _ :: attrs -> hasIfLetAttribute attrs -let isIfLetExpr expr = match expr with - | { - pexp_attributes = attrs; - pexp_desc = Pexp_match _ - } when hasIfLetAttribute attrs -> true +let isIfLetExpr expr = + match expr with + | {pexp_attributes = attrs; pexp_desc = Pexp_match _} + when hasIfLetAttribute attrs -> + true | _ -> false let hasAttributes attrs = - List.exists (fun attr -> match attr with - | ({Location.txt = "bs" | "res.template" | "ns.ternary" | "ns.braces" | "ns.iflet"}, _) -> false - (* Remove the fragile pattern warning for iflet expressions *) - | ({Location.txt="warning"}, PStr [{ - pstr_desc = Pstr_eval ({ - pexp_desc = Pexp_constant ( - Pconst_string ("-4", None) - ) - }, _) - }]) -> not (hasIfLetAttribute attrs) - | _ -> true - ) attrs - -let isArrayAccess expr = match expr.pexp_desc with - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, - [Nolabel, _parentExpr; Nolabel, _memberExpr] - ) -> true + List.exists + (fun attr -> + match attr with + | ( { + Location.txt = + "bs" | "res.template" | "ns.ternary" | "ns.braces" | "ns.iflet"; + }, + _ ) -> + false + (* Remove the fragile pattern warning for iflet expressions *) + | ( {Location.txt = "warning"}, + PStr + [ + { + pstr_desc = + Pstr_eval + ({pexp_desc = Pexp_constant (Pconst_string ("-4", None))}, _); + }; + ] ) -> + not (hasIfLetAttribute attrs) + | _ -> true) + attrs + +let isArrayAccess expr = + match expr.pexp_desc with + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, + [(Nolabel, _parentExpr); (Nolabel, _memberExpr)] ) -> + true | _ -> false - type ifConditionKind = -| If of Parsetree.expression -| IfLet of Parsetree.pattern * Parsetree.expression + | If of Parsetree.expression + | IfLet of Parsetree.pattern * Parsetree.expression let collectIfExpressions expr = - let rec collect acc expr = match expr.pexp_desc with - | Pexp_ifthenelse (ifExpr, thenExpr, Some elseExpr) -> - collect ((If(ifExpr), thenExpr)::acc) elseExpr - | Pexp_ifthenelse (ifExpr, thenExpr, (None as elseExpr)) -> - let ifs = List.rev ((If(ifExpr), thenExpr)::acc) in - (ifs, elseExpr) - | Pexp_match (condition, [{ - pc_lhs = pattern; - pc_guard = None; - pc_rhs = thenExpr; - }; { - pc_rhs = {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} - }]) when isIfLetExpr expr -> - let ifs = List.rev ((IfLet(pattern, condition), thenExpr)::acc) in - (ifs, None) - | Pexp_match (condition, [{ - pc_lhs = pattern; - pc_guard = None; - pc_rhs = thenExpr; - }; { - pc_rhs = elseExpr; - }]) when isIfLetExpr expr -> - collect ((IfLet(pattern, condition), thenExpr)::acc) elseExpr - | _ -> - (List.rev acc, Some expr) + let rec collect acc expr = + match expr.pexp_desc with + | Pexp_ifthenelse (ifExpr, thenExpr, Some elseExpr) -> + collect ((If ifExpr, thenExpr) :: acc) elseExpr + | Pexp_ifthenelse (ifExpr, thenExpr, (None as elseExpr)) -> + let ifs = List.rev ((If ifExpr, thenExpr) :: acc) in + (ifs, elseExpr) + | Pexp_match + ( condition, + [ + {pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr}; + { + pc_rhs = + {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}; + }; + ] ) + when isIfLetExpr expr -> + let ifs = List.rev ((IfLet (pattern, condition), thenExpr) :: acc) in + (ifs, None) + | Pexp_match + ( condition, + [ + {pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr}; + {pc_rhs = elseExpr}; + ] ) + when isIfLetExpr expr -> + collect ((IfLet (pattern, condition), thenExpr) :: acc) elseExpr + | _ -> (List.rev acc, Some expr) in collect [] expr let rec hasTernaryAttribute attrs = match attrs with | [] -> false - | ({Location.txt="ns.ternary"},_)::_ -> true - | _::attrs -> hasTernaryAttribute attrs + | ({Location.txt = "ns.ternary"}, _) :: _ -> true + | _ :: attrs -> hasTernaryAttribute attrs -let isTernaryExpr expr = match expr with - | { - pexp_attributes = attrs; - pexp_desc = Pexp_ifthenelse _ - } when hasTernaryAttribute attrs -> true +let isTernaryExpr expr = + match expr with + | {pexp_attributes = attrs; pexp_desc = Pexp_ifthenelse _} + when hasTernaryAttribute attrs -> + true | _ -> false let collectTernaryParts expr = - let rec collect acc expr = match expr with - | { - pexp_attributes = attrs; - pexp_desc = Pexp_ifthenelse (condition, consequent, Some(alternate)) - } when hasTernaryAttribute attrs -> collect ((condition, consequent)::acc) alternate - | alternate -> (List.rev acc, alternate) + let rec collect acc expr = + match expr with + | { + pexp_attributes = attrs; + pexp_desc = Pexp_ifthenelse (condition, consequent, Some alternate); + } + when hasTernaryAttribute attrs -> + collect ((condition, consequent) :: acc) alternate + | alternate -> (List.rev acc, alternate) in collect [] expr -let parametersShouldHug parameters = match parameters with - | [Parameter { - attrs = []; - lbl = Asttypes.Nolabel; - defaultExpr = None; - pat = pat - }] when isHuggablePattern pat -> true +let parametersShouldHug parameters = + match parameters with + | [Parameter {attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; pat}] + when isHuggablePattern pat -> + true | _ -> false let filterTernaryAttributes attrs = - List.filter (fun attr -> match attr with - |({Location.txt="ns.ternary"},_) -> false - | _ -> true - ) attrs + List.filter + (fun attr -> + match attr with + | {Location.txt = "ns.ternary"}, _ -> false + | _ -> true) + attrs let filterFragileMatchAttributes attrs = - List.filter (fun attr -> match attr with - | ({Location.txt="warning"}, PStr [{ - pstr_desc = Pstr_eval ({ - pexp_desc = Pexp_constant ( - Pconst_string ("-4", _) - ) - }, _) - }]) -> false - | _ -> true - ) attrs + List.filter + (fun attr -> + match attr with + | ( {Location.txt = "warning"}, + PStr + [ + { + pstr_desc = + Pstr_eval + ({pexp_desc = Pexp_constant (Pconst_string ("-4", _))}, _); + }; + ] ) -> + false + | _ -> true) + attrs let isJsxExpression expr = let rec loop attrs = match attrs with | [] -> false - | ({Location.txt = "JSX"}, _)::_ -> true - | _::attrs -> loop attrs + | ({Location.txt = "JSX"}, _) :: _ -> true + | _ :: attrs -> loop attrs in match expr.pexp_desc with - | Pexp_apply _ -> - loop expr.Parsetree.pexp_attributes + | Pexp_apply _ -> loop expr.Parsetree.pexp_attributes | _ -> false let hasJsxAttribute attributes = let rec loop attrs = match attrs with | [] -> false - | ({Location.txt = "JSX"}, _)::_ -> true - | _::attrs -> loop attrs + | ({Location.txt = "JSX"}, _) :: _ -> true + | _ :: attrs -> loop attrs in loop attributes let shouldIndentBinaryExpr expr = let samePrecedenceSubExpression operator subExpression = match subExpression with - | {pexp_desc = Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident subOperator}}, - [Nolabel, _lhs; Nolabel, _rhs] - )} when isBinaryOperator subOperator -> + | { + pexp_desc = + Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Lident subOperator}}, + [(Nolabel, _lhs); (Nolabel, _rhs)] ); + } + when isBinaryOperator subOperator -> flattenableOperators operator subOperator | _ -> true in match expr with - | {pexp_desc = Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [Nolabel, lhs; Nolabel, _rhs] - )} when isBinaryOperator operator -> - isEqualityOperator operator || - not (samePrecedenceSubExpression operator lhs) || - operator = ":=" + | { + pexp_desc = + Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [(Nolabel, lhs); (Nolabel, _rhs)] ); + } + when isBinaryOperator operator -> + isEqualityOperator operator + || (not (samePrecedenceSubExpression operator lhs)) + || operator = ":=" | _ -> false -let shouldInlineRhsBinaryExpr rhs = match rhs.pexp_desc with - | Parsetree.Pexp_constant _ - | Pexp_let _ - | Pexp_letmodule _ - | Pexp_letexception _ - | Pexp_sequence _ - | Pexp_open _ - | Pexp_ifthenelse _ - | Pexp_for _ - | Pexp_while _ - | Pexp_try _ - | Pexp_array _ - | Pexp_record _ -> true +let shouldInlineRhsBinaryExpr rhs = + match rhs.pexp_desc with + | Parsetree.Pexp_constant _ | Pexp_let _ | Pexp_letmodule _ + | Pexp_letexception _ | Pexp_sequence _ | Pexp_open _ | Pexp_ifthenelse _ + | Pexp_for _ | Pexp_while _ | Pexp_try _ | Pexp_array _ | Pexp_record _ -> + true | _ -> false let isPrintableAttribute attr = match attr with - | ({Location.txt="bs" | "res.template" | "ns.ternary" | "ns.braces" | "ns.iflet" | "JSX"}, _) -> false - | _ -> true + | ( { + Location.txt = + ( "bs" | "res.template" | "ns.ternary" | "ns.braces" | "ns.iflet" + | "JSX" ); + }, + _ ) -> + false + | _ -> true let hasPrintableAttributes attrs = List.exists isPrintableAttribute attrs let filterPrintableAttributes attrs = List.filter isPrintableAttribute attrs -let partitionPrintableAttributes attrs = List.partition isPrintableAttribute attrs +let partitionPrintableAttributes attrs = + List.partition isPrintableAttribute attrs let requiresSpecialCallbackPrintingLastArg args = - let rec loop args = match args with - | [] -> false - | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> true - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})::_ -> false - | _::rest -> loop rest + let rec loop args = + match args with + | [] -> false + | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> true + | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: _ -> false + | _ :: rest -> loop rest in loop args let requiresSpecialCallbackPrintingFirstArg args = - let rec loop args = match args with + let rec loop args = + match args with | [] -> true - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})::_ -> false - | _::rest -> loop rest + | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: _ -> false + | _ :: rest -> loop rest in match args with | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> false - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})::rest -> loop rest + | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: rest -> loop rest | _ -> false let modExprApply modExpr = - let rec loop acc modExpr = match modExpr with - | {pmod_desc = Pmod_apply (next, arg)} -> - loop (arg::acc) next - | _ -> (acc, modExpr) + let rec loop acc modExpr = + match modExpr with + | {pmod_desc = Pmod_apply (next, arg)} -> loop (arg :: acc) next + | _ -> (acc, modExpr) in loop [] modExpr let modExprFunctor modExpr = - let rec loop acc modExpr = match modExpr with - | {pmod_desc = Pmod_functor (lbl, modType, returnModExpr); pmod_attributes = attrs} -> - let param = (attrs, lbl, modType) in - loop (param::acc) returnModExpr - | returnModExpr -> - (List.rev acc, returnModExpr) + let rec loop acc modExpr = + match modExpr with + | { + pmod_desc = Pmod_functor (lbl, modType, returnModExpr); + pmod_attributes = attrs; + } -> + let param = (attrs, lbl, modType) in + loop (param :: acc) returnModExpr + | returnModExpr -> (List.rev acc, returnModExpr) in loop [] modExpr let rec collectPatternsFromListConstruct acc pattern = let open Parsetree in match pattern.ppat_desc with - | Ppat_construct( - {txt = Longident.Lident "::"}, - Some {ppat_desc=Ppat_tuple (pat::rest::[])} - ) -> - collectPatternsFromListConstruct (pat::acc) rest - | _ -> List.rev acc, pattern - - -let hasTemplateLiteralAttr attrs = List.exists (fun attr -> match attr with -| ({Location.txt = "res.template"}, _) -> true -| _ -> false) attrs + | Ppat_construct + ({txt = Longident.Lident "::"}, Some {ppat_desc = Ppat_tuple [pat; rest]}) + -> + collectPatternsFromListConstruct (pat :: acc) rest + | _ -> (List.rev acc, pattern) + +let hasTemplateLiteralAttr attrs = + List.exists + (fun attr -> + match attr with + | {Location.txt = "res.template"}, _ -> true + | _ -> false) + attrs let isTemplateLiteral expr = match expr.pexp_desc with - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, - [Nolabel, _; Nolabel, _] - ) when hasTemplateLiteralAttr expr.pexp_attributes -> true + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, + [(Nolabel, _); (Nolabel, _)] ) + when hasTemplateLiteralAttr expr.pexp_attributes -> + true | Pexp_constant (Pconst_string (_, Some "")) -> true | Pexp_constant _ when hasTemplateLiteralAttr expr.pexp_attributes -> true | _ -> false @@ -529,8 +578,8 @@ let isTemplateLiteral expr = let collectOrPatternChain pat = let rec loop pattern chain = match pattern.ppat_desc with - | Ppat_or (left, right) -> loop left (right::chain) - | _ -> pattern::chain + | Ppat_or (left, right) -> loop left (right :: chain) + | _ -> pattern :: chain in loop pat [] @@ -547,28 +596,30 @@ let isSinglePipeExpr expr = * } * ) *) - let isPipeExpr expr = match expr.pexp_desc with - | Pexp_apply( - {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>") }}, - [(Nolabel, _operand1); (Nolabel, _operand2)] - ) -> true - | _ -> false + let isPipeExpr expr = + match expr.pexp_desc with + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>")}}, + [(Nolabel, _operand1); (Nolabel, _operand2)] ) -> + true + | _ -> false in match expr.pexp_desc with - | Pexp_apply( - {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>") }}, - [(Nolabel, operand1); (Nolabel, _operand2)] - ) when not (isPipeExpr operand1) -> true + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>")}}, + [(Nolabel, operand1); (Nolabel, _operand2)] ) + when not (isPipeExpr operand1) -> + true | _ -> false let isUnderscoreApplySugar expr = match expr.pexp_desc with - | Pexp_fun ( - Nolabel, - None, - {ppat_desc = Ppat_var {txt="__x"}}, - {pexp_desc = Pexp_apply _} - ) -> true + | Pexp_fun + ( Nolabel, + None, + {ppat_desc = Ppat_var {txt = "__x"}}, + {pexp_desc = Pexp_apply _} ) -> + true | _ -> false let isRewrittenUnderscoreApplySugar expr = diff --git a/src/res_parsetree_viewer.mli b/src/res_parsetree_viewer.mli index c196d8b1..12698897 100644 --- a/src/res_parsetree_viewer.mli +++ b/src/res_parsetree_viewer.mli @@ -1,121 +1,128 @@ (* Restructures a nested tree of arrow types into its args & returnType * The parsetree contains: a => b => c => d, for printing purposes * we restructure the tree into (a, b, c) and its returnType d *) - val arrowType: Parsetree.core_type -> - Parsetree.attributes * - (Parsetree.attributes * Asttypes.arg_label * Parsetree.core_type) list * - Parsetree.core_type - -val functorType: Parsetree.module_type -> - (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) list * - Parsetree.module_type +val arrowType : + Parsetree.core_type -> + Parsetree.attributes + * (Parsetree.attributes * Asttypes.arg_label * Parsetree.core_type) list + * Parsetree.core_type + +val functorType : + Parsetree.module_type -> + (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) + list + * Parsetree.module_type (* filters @bs out of the provided attributes *) -val processUncurriedAttribute: Parsetree.attributes -> bool * Parsetree.attributes +val processUncurriedAttribute : + Parsetree.attributes -> bool * Parsetree.attributes type ifConditionKind = | If of Parsetree.expression | IfLet of Parsetree.pattern * Parsetree.expression (* if ... else if ... else ... is represented as nested expressions: if ... else { if ... } -* The purpose of this function is to flatten nested ifs into one sequence. -* Basically compute: ([if, else if, else if, else if], else) *) -val collectIfExpressions: - Parsetree.expression -> - (ifConditionKind * Parsetree.expression) list * Parsetree.expression option + * The purpose of this function is to flatten nested ifs into one sequence. + * Basically compute: ([if, else if, else if, else if], else) *) +val collectIfExpressions : + Parsetree.expression -> + (ifConditionKind * Parsetree.expression) list * Parsetree.expression option -val collectListExpressions: - Parsetree.expression -> (Parsetree.expression list * Parsetree.expression option) +val collectListExpressions : + Parsetree.expression -> + Parsetree.expression list * Parsetree.expression option type funParamKind = - | Parameter of { - attrs: Parsetree.attributes; - lbl: Asttypes.arg_label; - defaultExpr: Parsetree.expression option; - pat: Parsetree.pattern; - } - | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} - -val funExpr: - Parsetree.expression -> - Parsetree.attributes * - funParamKind list * - Parsetree.expression + | Parameter of { + attrs: Parsetree.attributes; + lbl: Asttypes.arg_label; + defaultExpr: Parsetree.expression option; + pat: Parsetree.pattern; + } + | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} + +val funExpr : + Parsetree.expression -> + Parsetree.attributes * funParamKind list * Parsetree.expression (* example: -* `makeCoordinate({ -* x: 1, -* y: 2, -* })` -* Notice howe `({` and `})` "hug" or stick to each other *) -val isHuggableExpression: Parsetree.expression -> bool + * `makeCoordinate({ + * x: 1, + * y: 2, + * })` + * Notice howe `({` and `})` "hug" or stick to each other *) +val isHuggableExpression : Parsetree.expression -> bool -val isHuggablePattern: Parsetree.pattern -> bool +val isHuggablePattern : Parsetree.pattern -> bool -val isHuggableRhs: Parsetree.expression -> bool +val isHuggableRhs : Parsetree.expression -> bool -val operatorPrecedence: string -> int +val operatorPrecedence : string -> int -val isUnaryExpression: Parsetree.expression -> bool -val isBinaryOperator: string -> bool -val isBinaryExpression: Parsetree.expression -> bool +val isUnaryExpression : Parsetree.expression -> bool +val isBinaryOperator : string -> bool +val isBinaryExpression : Parsetree.expression -> bool -val flattenableOperators: string -> string -> bool +val flattenableOperators : string -> string -> bool -val hasAttributes: Parsetree.attributes -> bool +val hasAttributes : Parsetree.attributes -> bool -val isArrayAccess: Parsetree.expression -> bool -val isTernaryExpr: Parsetree.expression -> bool -val isIfLetExpr: Parsetree.expression -> bool +val isArrayAccess : Parsetree.expression -> bool +val isTernaryExpr : Parsetree.expression -> bool +val isIfLetExpr : Parsetree.expression -> bool -val collectTernaryParts: Parsetree.expression -> ((Parsetree.expression * Parsetree.expression) list * Parsetree.expression) +val collectTernaryParts : + Parsetree.expression -> + (Parsetree.expression * Parsetree.expression) list * Parsetree.expression -val parametersShouldHug: - funParamKind list -> bool +val parametersShouldHug : funParamKind list -> bool -val filterTernaryAttributes: Parsetree.attributes -> Parsetree.attributes -val filterFragileMatchAttributes: Parsetree.attributes -> Parsetree.attributes +val filterTernaryAttributes : Parsetree.attributes -> Parsetree.attributes +val filterFragileMatchAttributes : Parsetree.attributes -> Parsetree.attributes -val isJsxExpression: Parsetree.expression -> bool -val hasJsxAttribute: Parsetree.attributes -> bool +val isJsxExpression : Parsetree.expression -> bool +val hasJsxAttribute : Parsetree.attributes -> bool -val shouldIndentBinaryExpr: Parsetree.expression -> bool -val shouldInlineRhsBinaryExpr: Parsetree.expression -> bool -val hasPrintableAttributes: Parsetree.attributes -> bool -val filterPrintableAttributes: Parsetree.attributes -> Parsetree.attributes -val partitionPrintableAttributes: Parsetree.attributes -> (Parsetree.attributes * Parsetree.attributes) +val shouldIndentBinaryExpr : Parsetree.expression -> bool +val shouldInlineRhsBinaryExpr : Parsetree.expression -> bool +val hasPrintableAttributes : Parsetree.attributes -> bool +val filterPrintableAttributes : Parsetree.attributes -> Parsetree.attributes +val partitionPrintableAttributes : + Parsetree.attributes -> Parsetree.attributes * Parsetree.attributes -val requiresSpecialCallbackPrintingLastArg: (Asttypes.arg_label * Parsetree.expression) list -> bool -val requiresSpecialCallbackPrintingFirstArg: (Asttypes.arg_label * Parsetree.expression) list -> bool +val requiresSpecialCallbackPrintingLastArg : + (Asttypes.arg_label * Parsetree.expression) list -> bool +val requiresSpecialCallbackPrintingFirstArg : + (Asttypes.arg_label * Parsetree.expression) list -> bool -val modExprApply : Parsetree.module_expr -> ( - Parsetree.module_expr list * Parsetree.module_expr -) +val modExprApply : + Parsetree.module_expr -> Parsetree.module_expr list * Parsetree.module_expr (* Collection of utilities to view the ast in a more a convenient form, * allowing for easier processing. * Example: given a ptyp_arrow type, what are its arguments and what is the * returnType? *) +val modExprFunctor : + Parsetree.module_expr -> + (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) + list + * Parsetree.module_expr -val modExprFunctor : Parsetree.module_expr -> ( - (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) list * - Parsetree.module_expr -) - -val collectPatternsFromListConstruct: - Parsetree.pattern list -> Parsetree.pattern -> - (Parsetree.pattern list * Parsetree.pattern) +val collectPatternsFromListConstruct : + Parsetree.pattern list -> + Parsetree.pattern -> + Parsetree.pattern list * Parsetree.pattern val isBlockExpr : Parsetree.expression -> bool -val isTemplateLiteral: Parsetree.expression -> bool -val hasTemplateLiteralAttr: Parsetree.attributes -> bool +val isTemplateLiteral : Parsetree.expression -> bool +val hasTemplateLiteralAttr : Parsetree.attributes -> bool -val collectOrPatternChain: - Parsetree.pattern -> Parsetree.pattern list +val collectOrPatternChain : Parsetree.pattern -> Parsetree.pattern list -val processBracesAttr : Parsetree.expression -> (Parsetree.attribute option * Parsetree.expression) +val processBracesAttr : + Parsetree.expression -> Parsetree.attribute option * Parsetree.expression val filterParsingAttrs : Parsetree.attributes -> Parsetree.attributes @@ -124,11 +131,11 @@ val isBracedExpr : Parsetree.expression -> bool val isSinglePipeExpr : Parsetree.expression -> bool (* (__x) => f(a, __x, c) -----> f(a, _, c) *) -val rewriteUnderscoreApply: Parsetree.expression -> Parsetree.expression +val rewriteUnderscoreApply : Parsetree.expression -> Parsetree.expression (* (__x) => f(a, __x, c) -----> f(a, _, c) *) -val isUnderscoreApplySugar: Parsetree.expression -> bool +val isUnderscoreApplySugar : Parsetree.expression -> bool -val hasIfLetAttribute: Parsetree.attributes -> bool +val hasIfLetAttribute : Parsetree.attributes -> bool -val isRewrittenUnderscoreApplySugar: Parsetree.expression -> bool +val isRewrittenUnderscoreApplySugar : Parsetree.expression -> bool diff --git a/src/res_printer.mli b/src/res_printer.mli index bfd0cd4d..267ae091 100644 --- a/src/res_printer.mli +++ b/src/res_printer.mli @@ -2,7 +2,9 @@ val convertBsExternalAttribute : string -> string val convertBsExtension : string -> string val printTypeParams : - (Parsetree.core_type * Asttypes.variance) list -> Res_comments_table.t -> Res_doc.t + (Parsetree.core_type * Asttypes.variance) list -> + Res_comments_table.t -> + Res_doc.t val printLongident : Longident.t -> Res_doc.t @@ -12,7 +14,8 @@ val addParens : Res_doc.t -> Res_doc.t val printExpression : Parsetree.expression -> Res_comments_table.t -> Res_doc.t -val printStructure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t [@@live] +val printStructure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t + [@@live] val printImplementation : width:int -> Parsetree.structure -> comments:Res_comment.t list -> string diff --git a/src/res_reporting.ml b/src/res_reporting.ml index f5bd4fe7..77d370af 100644 --- a/src/res_reporting.ml +++ b/src/res_reporting.ml @@ -3,7 +3,11 @@ module Grammar = Res_grammar type problem = | Unexpected of Token.t [@live] - | Expected of {token: Token.t; pos: Lexing.position; context: Grammar.t option} [@live] + | Expected of { + token: Token.t; + pos: Lexing.position; + context: Grammar.t option; + } [@live] | Message of string [@live] | Uident [@live] | Lident [@live] diff --git a/src/res_scanner.ml b/src/res_scanner.ml index d389489d..abff9112 100644 --- a/src/res_scanner.ml +++ b/src/res_scanner.ml @@ -5,8 +5,8 @@ module Comment = Res_comment type mode = Jsx | Diamond (* We hide the implementation detail of the scanner reading character. Our char -will also contain the special -1 value to indicate end-of-file. This isn't -ideal; we should clean this up *) + will also contain the special -1 value to indicate end-of-file. This isn't + ideal; we should clean this up *) let hackyEOFChar = Char.unsafe_chr (-1) type charEncoding = Char.t @@ -14,10 +14,10 @@ type t = { filename: string; src: string; mutable err: - startPos: Lexing.position - -> endPos: Lexing.position - -> Diagnostics.category - -> unit; + startPos:Lexing.position -> + endPos:Lexing.position -> + Diagnostics.category -> + unit; mutable ch: charEncoding; (* current character *) mutable offset: int; (* character offset *) mutable lineOffset: int; (* current line offset *) @@ -25,52 +25,53 @@ type t = { mutable mode: mode list; } -let setDiamondMode scanner = - scanner.mode <- Diamond::scanner.mode +let setDiamondMode scanner = scanner.mode <- Diamond :: scanner.mode -let setJsxMode scanner = - scanner.mode <- Jsx::scanner.mode +let setJsxMode scanner = scanner.mode <- Jsx :: scanner.mode let popMode scanner mode = match scanner.mode with - | m::ms when m = mode -> - scanner.mode <- ms + | m :: ms when m = mode -> scanner.mode <- ms | _ -> () -let inDiamondMode scanner = match scanner.mode with - | Diamond::_ -> true +let inDiamondMode scanner = + match scanner.mode with + | Diamond :: _ -> true | _ -> false -let inJsxMode scanner = match scanner.mode with - | Jsx::_ -> true +let inJsxMode scanner = + match scanner.mode with + | Jsx :: _ -> true | _ -> false -let position scanner = Lexing.{ - pos_fname = scanner.filename; - (* line number *) - pos_lnum = scanner.lnum; - (* offset of the beginning of the line (number - of characters between the beginning of the scanner and the beginning - of the line) *) - pos_bol = scanner.lineOffset; - (* [pos_cnum] is the offset of the position (number of - characters between the beginning of the scanner and the position). *) - pos_cnum = scanner.offset; -} +let position scanner = + Lexing. + { + pos_fname = scanner.filename; + (* line number *) + pos_lnum = scanner.lnum; + (* offset of the beginning of the line (number + of characters between the beginning of the scanner and the beginning + of the line) *) + pos_bol = scanner.lineOffset; + (* [pos_cnum] is the offset of the position (number of + characters between the beginning of the scanner and the position). *) + pos_cnum = scanner.offset; + } (* Small debugging util -❯ echo 'let msg = "hello"' | ./lib/rescript.exe -let msg = "hello" -^-^ let 0-3 -let msg = "hello" - ^-^ msg 4-7 -let msg = "hello" - ^ = 8-9 -let msg = "hello" - ^-----^ string "hello" 10-17 -let msg = "hello" - ^ eof 18-18 -let msg = "hello" + ❯ echo 'let msg = "hello"' | ./lib/rescript.exe + let msg = "hello" + ^-^ let 0-3 + let msg = "hello" + ^-^ msg 4-7 + let msg = "hello" + ^ = 8-9 + let msg = "hello" + ^-----^ string "hello" 10-17 + let msg = "hello" + ^ eof 18-18 + let msg = "hello" *) let _printDebug ~startPos ~endPos scanner token = let open Lexing in @@ -78,14 +79,11 @@ let _printDebug ~startPos ~endPos scanner token = print_string ((String.make [@doesNotRaise]) startPos.pos_cnum ' '); print_char '^'; (match endPos.pos_cnum - startPos.pos_cnum with - | 0 -> - if token = Token.Eof then () - else assert false + | 0 -> if token = Token.Eof then () else assert false | 1 -> () - | n -> ( + | n -> print_string ((String.make [@doesNotRaise]) (n - 2) '-'); - print_char '^'; - )); + print_char '^'); print_char ' '; print_string (Res_token.toString token); print_char ' '; @@ -93,25 +91,24 @@ let _printDebug ~startPos ~endPos scanner token = print_char '-'; print_int endPos.pos_cnum; print_endline "" -[@@live] + [@@live] let next scanner = let nextOffset = scanner.offset + 1 in (match scanner.ch with | '\n' -> scanner.lineOffset <- nextOffset; - scanner.lnum <- scanner.lnum + 1; + scanner.lnum <- scanner.lnum + 1 (* What about CRLF (\r + \n) on windows? * \r\n will always be terminated by a \n * -> we can just bump the line count on \n *) | _ -> ()); if nextOffset < String.length scanner.src then ( scanner.offset <- nextOffset; - scanner.ch <- String.unsafe_get scanner.src scanner.offset; - ) else ( + scanner.ch <- String.unsafe_get scanner.src scanner.offset) + else ( scanner.offset <- String.length scanner.src; - scanner.ch <- hackyEOFChar - ) + scanner.ch <- hackyEOFChar) let next2 scanner = next scanner; @@ -125,34 +122,30 @@ let next3 scanner = let peek scanner = if scanner.offset + 1 < String.length scanner.src then String.unsafe_get scanner.src (scanner.offset + 1) - else - hackyEOFChar + else hackyEOFChar let peek2 scanner = if scanner.offset + 2 < String.length scanner.src then String.unsafe_get scanner.src (scanner.offset + 2) - else - hackyEOFChar + else hackyEOFChar let peek3 scanner = if scanner.offset + 3 < String.length scanner.src then String.unsafe_get scanner.src (scanner.offset + 3) - else - hackyEOFChar + else hackyEOFChar let make ~filename src = { filename; - src = src; + src; err = (fun ~startPos:_ ~endPos:_ _ -> ()); - ch = if src = "" then hackyEOFChar else String.unsafe_get src 0; + ch = (if src = "" then hackyEOFChar else String.unsafe_get src 0); offset = 0; lineOffset = 0; lnum = 1; mode = []; } - (* generic helpers *) let isWhitespace ch = @@ -163,82 +156,96 @@ let isWhitespace ch = let rec skipWhitespace scanner = if isWhitespace scanner.ch then ( next scanner; - skipWhitespace scanner - ) + skipWhitespace scanner) let digitValue ch = match ch with - | '0'..'9' -> (Char.code ch) - 48 - | 'a'..'f' -> - (Char.code ch) - (Char.code 'a') + 10 - | 'A'..'F' -> - (Char.code ch) + 32 - (Char.code 'a') + 10 + | '0' .. '9' -> Char.code ch - 48 + | 'a' .. 'f' -> Char.code ch - Char.code 'a' + 10 + | 'A' .. 'F' -> Char.code ch + 32 - Char.code 'a' + 10 | _ -> 16 (* larger than any legal value *) let rec skipLowerCaseChars scanner = match scanner.ch with - | 'a'..'z' -> next scanner; skipLowerCaseChars scanner + | 'a' .. 'z' -> + next scanner; + skipLowerCaseChars scanner | _ -> () - (* scanning helpers *) let scanIdentifier scanner = let startOff = scanner.offset in let rec skipGoodChars scanner = match scanner.ch with - | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> + | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '\'' -> next scanner; skipGoodChars scanner | _ -> () in skipGoodChars scanner; - let str = (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) in - if '{' == scanner.ch && str = "list" then begin + let str = + (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) + in + if '{' == scanner.ch && str = "list" then ( next scanner; (* TODO: this isn't great *) - Token.lookupKeyword "list{" - end + Token.lookupKeyword "list{") else Token.lookupKeyword str let scanDigits scanner ~base = if base <= 10 then let rec loop scanner = match scanner.ch with - | '0'..'9' | '_' -> next scanner; loop scanner + | '0' .. '9' | '_' -> + next scanner; + loop scanner | _ -> () - in loop scanner + in + loop scanner else let rec loop scanner = match scanner.ch with (* hex *) - | '0'..'9' | 'a'..'f' | 'A'..'F' | '_' -> next scanner; loop scanner + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' -> + next scanner; + loop scanner | _ -> () - in loop scanner + in + loop scanner (* float: (0…9) { 0…9∣ _ } [. { 0…9∣ _ }] [(e∣ E) [+∣ -] (0…9) { 0…9∣ _ }] *) let scanNumber scanner = let startOff = scanner.offset in (* integer part *) - let base = match scanner.ch with - | '0' -> - (match peek scanner with - | 'x' | 'X' -> next2 scanner; 16 - | 'o' | 'O' -> next2 scanner; 8 - | 'b' | 'B' -> next2 scanner; 2 - | _ -> next scanner; 8) - | _ -> 10 + let base = + match scanner.ch with + | '0' -> ( + match peek scanner with + | 'x' | 'X' -> + next2 scanner; + 16 + | 'o' | 'O' -> + next2 scanner; + 8 + | 'b' | 'B' -> + next2 scanner; + 2 + | _ -> + next scanner; + 8) + | _ -> 10 in scanDigits scanner ~base; (* *) - let isFloat = if '.' == scanner.ch then ( - next scanner; - scanDigits scanner ~base; - true - ) else - false + let isFloat = + if '.' == scanner.ch then ( + next scanner; + scanDigits scanner ~base; + true) + else false in (* exponent part *) @@ -261,24 +268,19 @@ let scanNumber scanner = match scanner.ch with | 'n' -> let msg = - "Unsupported number type (nativeint). Did you mean `" - ^ literal - ^ "`?" + "Unsupported number type (nativeint). Did you mean `" ^ literal ^ "`?" in let pos = position scanner in scanner.err ~startPos:pos ~endPos:pos (Diagnostics.message msg); next scanner; Some 'n' - | 'g'..'z' | 'G'..'Z' as ch -> + | ('g' .. 'z' | 'G' .. 'Z') as ch -> next scanner; Some ch - | _ -> - None + | _ -> None in - if isFloat then - Token.Float {f = literal; suffix} - else - Token.Int {i = literal; suffix} + if isFloat then Token.Float {f = literal; suffix} + else Token.Int {i = literal; suffix} let scanExoticIdentifier scanner = (* TODO: are we disregarding the current char...? Should be a quote *) @@ -292,11 +294,13 @@ let scanExoticIdentifier scanner = | '\n' | '\r' -> (* line break *) let endPos = position scanner in - scanner.err ~startPos ~endPos (Diagnostics.message "A quoted identifier can't contain line breaks."); + scanner.err ~startPos ~endPos + (Diagnostics.message "A quoted identifier can't contain line breaks."); next scanner | ch when ch == hackyEOFChar -> let endPos = position scanner in - scanner.err ~startPos ~endPos (Diagnostics.message "Did you forget a \" here?") + scanner.err ~startPos ~endPos + (Diagnostics.message "Did you forget a \" here?") | ch -> Buffer.add_char buffer ch; next scanner; @@ -312,29 +316,28 @@ let scanStringEscapeSequence ~startPos scanner = if n == 0 then x else let d = digitValue scanner.ch in - if d >= base then + if d >= base then ( let pos = position scanner in let msg = if scanner.ch == hackyEOFChar then "unclosed escape sequence" else "unknown escape sequence" in scanner.err ~startPos ~endPos:pos (Diagnostics.message msg); - -1 + -1) else let () = next scanner in - loop (n - 1) (x * base + d) + loop (n - 1) ((x * base) + d) in let x = loop n 0 in - if x > max || 0xD800 <= x && x < 0xE000 then + if x > max || (0xD800 <= x && x < 0xE000) then let pos = position scanner in let msg = "escape sequence is invalid unicode code point" in scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) in match scanner.ch with (* \ already consumed *) - | 'n' | 't' | 'b' | 'r' | '\\' | ' ' | '\'' | '"' -> - next scanner - | '0'..'9' -> + | 'n' | 't' | 'b' | 'r' | '\\' | ' ' | '\'' | '"' -> next scanner + | '0' .. '9' -> (* decimal *) scan ~n:3 ~base:10 ~max:255 | 'o' -> @@ -345,24 +348,26 @@ let scanStringEscapeSequence ~startPos scanner = (* hex *) next scanner; scan ~n:2 ~base:16 ~max:255 - | 'u' -> + | 'u' -> ( next scanner; - (match scanner.ch with - | '{' -> + match scanner.ch with + | '{' -> ( (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) next scanner; let x = ref 0 in - while match scanner.ch with | '0'..'9' | 'a'..'f' | 'A'..'F' -> true | _ -> false do - x := (!x * 16) + (digitValue scanner.ch); + while + match scanner.ch with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false + do + x := (!x * 16) + digitValue scanner.ch; next scanner done; (* consume '}' in '\u{7A}' *) - (match scanner.ch with + match scanner.ch with | '}' -> next scanner - | _ -> ()); - | _ -> - scan ~n:4 ~base:16 ~max:Res_utf8.max - ) + | _ -> ()) + | _ -> scan ~n:4 ~base:16 ~max:Res_utf8.max) | _ -> (* unknown escape sequence * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat *) @@ -378,7 +383,6 @@ let scanStringEscapeSequence ~startPos scanner = let scanString scanner = (* assumption: we've just matched a quote *) - let startPosWithQuote = position scanner in next scanner; let firstCharOffset = scanner.offset in @@ -388,7 +392,8 @@ let scanString scanner = | '"' -> let lastCharOffset = scanner.offset in next scanner; - (String.sub [@doesNotRaise]) scanner.src firstCharOffset (lastCharOffset - firstCharOffset) + (String.sub [@doesNotRaise]) scanner.src firstCharOffset + (lastCharOffset - firstCharOffset) | '\\' -> let startPos = position scanner in next scanner; @@ -397,7 +402,8 @@ let scanString scanner = | ch when ch == hackyEOFChar -> let endPos = position scanner in scanner.err ~startPos:startPosWithQuote ~endPos Diagnostics.unclosedString; - (String.sub [@doesNotRaise]) scanner.src firstCharOffset (scanner.offset - firstCharOffset) + (String.sub [@doesNotRaise]) scanner.src firstCharOffset + (scanner.offset - firstCharOffset) | _ -> next scanner; scan () @@ -415,47 +421,64 @@ let scanEscape scanner = next scanner done; let c = !x in - if Res_utf8.isValidCodePoint c then - Char.unsafe_chr c - else - Char.unsafe_chr Res_utf8.repl + if Res_utf8.isValidCodePoint c then Char.unsafe_chr c + else Char.unsafe_chr Res_utf8.repl in - let codepoint = match scanner.ch with - | '0'..'9' -> convertNumber scanner ~n:3 ~base:10 - | 'b' -> next scanner; '\008' - | 'n' -> next scanner; '\010' - | 'r' -> next scanner; '\013' - | 't' -> next scanner; '\009' - | 'x' -> next scanner; convertNumber scanner ~n:2 ~base:16 - | 'o' -> next scanner; convertNumber scanner ~n:3 ~base:8 - | 'u' -> - next scanner; - begin match scanner.ch with - | '{' -> - (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) + let codepoint = + match scanner.ch with + | '0' .. '9' -> convertNumber scanner ~n:3 ~base:10 + | 'b' -> next scanner; - let x = ref 0 in - while match scanner.ch with | '0'..'9' | 'a'..'f' | 'A'..'F' -> true | _ -> false do - x := (!x * 16) + (digitValue scanner.ch); - next scanner - done; - (* consume '}' in '\u{7A}' *) - (match scanner.ch with - | '}' -> next scanner - | _ -> ()); - let c = !x in - if Res_utf8.isValidCodePoint c then - Char.unsafe_chr c - else - Char.unsafe_chr Res_utf8.repl - | _ -> - (* unicode escape sequence: '\u007A', exactly 4 hex digits *) - convertNumber scanner ~n:4 ~base:16 - end - | ch -> next scanner; ch + '\008' + | 'n' -> + next scanner; + '\010' + | 'r' -> + next scanner; + '\013' + | 't' -> + next scanner; + '\009' + | 'x' -> + next scanner; + convertNumber scanner ~n:2 ~base:16 + | 'o' -> + next scanner; + convertNumber scanner ~n:3 ~base:8 + | 'u' -> ( + next scanner; + match scanner.ch with + | '{' -> + (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) + next scanner; + let x = ref 0 in + while + match scanner.ch with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false + do + x := (!x * 16) + digitValue scanner.ch; + next scanner + done; + (* consume '}' in '\u{7A}' *) + (match scanner.ch with + | '}' -> next scanner + | _ -> ()); + let c = !x in + if Res_utf8.isValidCodePoint c then Char.unsafe_chr c + else Char.unsafe_chr Res_utf8.repl + | _ -> + (* unicode escape sequence: '\u007A', exactly 4 hex digits *) + convertNumber scanner ~n:4 ~base:16) + | ch -> + next scanner; + ch + in + let contents = + (String.sub [@doesNotRaise]) scanner.src offset (scanner.offset - offset) in - let contents = (String.sub [@doesNotRaise]) scanner.src offset (scanner.offset - offset) in - next scanner; (* Consume \' *) + next scanner; + (* Consume \' *) (* TODO: do we know it's \' ? *) Token.Codepoint {c = codepoint; original = contents} @@ -472,23 +495,24 @@ let scanSingleLineComment scanner = in skip scanner; let endPos = position scanner in - Token.Comment ( - Comment.makeSingleLineComment - ~loc:(Location.{loc_start = startPos; loc_end = endPos; loc_ghost = false}) - ((String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff)) - ) + Token.Comment + (Comment.makeSingleLineComment + ~loc:Location.{loc_start = startPos; loc_end = endPos; loc_ghost = false} + ((String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - startOff))) let scanMultiLineComment scanner = (* assumption: we're only ever using this helper in `scan` after detecting a comment *) let docComment = - peek2 scanner = '*' && - peek3 scanner <> '/' (* no /**/ *) && - peek3 scanner <> '*' (* no /*** *) in - let contentStartOff = scanner.offset + (if docComment then 3 else 2) in + peek2 scanner = '*' + && peek3 scanner <> '/' + (* no /**/ *) && peek3 scanner <> '*' (* no /*** *) + in + let contentStartOff = scanner.offset + if docComment then 3 else 2 in let startPos = position scanner in let rec scan ~depth = (* invariant: depth > 0 right after this match. See assumption *) - match scanner.ch, peek scanner with + match (scanner.ch, peek scanner) with | '/', '*' -> next2 scanner; scan ~depth:(depth + 1) @@ -505,11 +529,12 @@ let scanMultiLineComment scanner = scan ~depth:0; let length = scanner.offset - 2 - contentStartOff in let length = if length < 0 (* in case of EOF *) then 0 else length in - Token.Comment ( - Comment.makeMultiLineComment ~docComment - ~loc:(Location.{loc_start = startPos; loc_end = (position scanner); loc_ghost = false}) - ((String.sub [@doesNotRaise]) scanner.src contentStartOff length) - ) + Token.Comment + (Comment.makeMultiLineComment ~docComment + ~loc: + Location. + {loc_start = startPos; loc_end = position scanner; loc_ghost = false} + ((String.sub [@doesNotRaise]) scanner.src contentStartOff length)) let scanTemplateLiteralToken scanner = let startOff = scanner.offset in @@ -523,24 +548,24 @@ let scanTemplateLiteralToken scanner = match scanner.ch with | '`' -> next scanner; - Token.TemplateTail( - (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - 1 - startOff) - ) - | '$' -> - (match peek scanner with + Token.TemplateTail + ((String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - 1 - startOff)) + | '$' -> ( + match peek scanner with | '{' -> next2 scanner; let contents = - (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - 2 - startOff) + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - 2 - startOff) in Token.TemplatePart contents | _ -> next scanner; - scan()) - | '\\' -> - (match peek scanner with - | '`' | '\\' | '$' - | '\n' | '\r' -> + scan ()) + | '\\' -> ( + match peek scanner with + | '`' | '\\' | '$' | '\n' | '\r' -> (* line break *) next2 scanner; scan () @@ -550,9 +575,9 @@ let scanTemplateLiteralToken scanner = | ch when ch = hackyEOFChar -> let endPos = position scanner in scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; - Token.TemplateTail( - (String.sub [@doesNotRaise]) scanner.src startOff (max (scanner.offset - 1 - startOff) 0) - ) + Token.TemplateTail + ((String.sub [@doesNotRaise]) scanner.src startOff + (max (scanner.offset - 1 - startOff) 0)) | _ -> next scanner; scan () @@ -565,162 +590,281 @@ let rec scan scanner = skipWhitespace scanner; let startPos = position scanner in - let token = match scanner.ch with - (* peeking 0 char *) - | 'A'..'Z' | 'a'..'z' -> scanIdentifier scanner - | '0'..'9' -> scanNumber scanner - | '`' -> next scanner; Token.Backtick - | '~' -> next scanner; Token.Tilde - | '?' -> next scanner; Token.Question - | ';' -> next scanner; Token.Semicolon - | '(' -> next scanner; Token.Lparen - | ')' -> next scanner; Token.Rparen - | '[' -> next scanner; Token.Lbracket - | ']' -> next scanner; Token.Rbracket - | '{' -> next scanner; Token.Lbrace - | '}' -> next scanner; Token.Rbrace - | ',' -> next scanner; Token.Comma - | '"' -> scanString scanner - - (* peeking 1 char *) - | '_' -> - (match peek scanner with - | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> scanIdentifier scanner - | _ -> next scanner; Token.Underscore) - | '#' -> - (match peek scanner with - | '=' -> next2 scanner; Token.HashEqual - | _ -> next scanner; Token.Hash) - | '*' -> - (match peek scanner with - | '*' -> next2 scanner; Token.Exponentiation - | '.' -> next2 scanner; Token.AsteriskDot - | _ -> next scanner; Token.Asterisk) - | '@' -> - (match peek scanner with - | '@' -> next2 scanner; Token.AtAt - | _ -> next scanner; Token.At) - | '%' -> - (match peek scanner with - | '%' -> next2 scanner; Token.PercentPercent - | _ -> next scanner; Token.Percent) - | '|' -> - (match peek scanner with - | '|' -> next2 scanner; Token.Lor - | '>' -> next2 scanner; Token.BarGreater - | _ -> next scanner; Token.Bar) - | '&' -> - (match peek scanner with - | '&' -> next2 scanner; Token.Land - | _ -> next scanner; Token.Band) - | ':' -> - (match peek scanner with - | '=' -> next2 scanner; Token.ColonEqual - | '>' -> next2 scanner; Token.ColonGreaterThan - | _ -> next scanner; Token.Colon) - | '\\' -> next scanner; scanExoticIdentifier scanner - | '/' -> - (match peek scanner with - | '/' -> next2 scanner; scanSingleLineComment scanner - | '*' -> scanMultiLineComment scanner - | '.' -> next2 scanner; Token.ForwardslashDot - | _ -> next scanner; Token.Forwardslash) - | '-' -> - (match peek scanner with - | '.' -> next2 scanner; Token.MinusDot - | '>' -> next2 scanner; Token.MinusGreater - | _ -> next scanner; Token.Minus) - | '+' -> - (match peek scanner with - | '.' -> next2 scanner; Token.PlusDot - | '+' -> next2 scanner; Token.PlusPlus - | '=' -> next2 scanner; Token.PlusEqual - | _ -> next scanner; Token.Plus) - | '>' -> - (match peek scanner with - | '=' when not (inDiamondMode scanner) -> next2 scanner; Token.GreaterEqual - | _ -> next scanner; Token.GreaterThan) - | '<' when not (inJsxMode scanner) -> - (match peek scanner with - | '=' -> next2 scanner; Token.LessEqual - | _ -> next scanner; Token.LessThan) - (* special handling for JSX < *) - | '<' -> - (* Imagine the following:
< - * < indicates the start of a new jsx-element, the parser expects - * the name of a new element after the < - * Example:
- * This signals a closing element. To simulate the two-token lookahead, - * the next scanner; Token.LessThanSlash - | '=' -> next scanner; Token.LessEqual - | _ -> Token.LessThan) - - (* peeking 2 chars *) - | '.' -> - (match peek scanner, peek2 scanner with - | '.', '.' -> next3 scanner; Token.DotDotDot - | '.', _ -> next2 scanner; Token.DotDot - | _ -> next scanner; Token.Dot) - | '\'' -> - (match peek scanner, peek2 scanner with - | '\\', '"' -> - (* careful with this one! We're next-ing _once_ (not twice), - then relying on matching on the quote *) - next scanner; SingleQuote - | '\\', _ -> next2 scanner; scanEscape scanner - | ch, '\'' -> - let offset = scanner.offset + 1 in - next3 scanner; - Token.Codepoint {c = ch; original = (String.sub [@doesNotRaise]) scanner.src offset 1} - | ch, _ -> - next scanner; - let offset = scanner.offset in - let (codepoint, length) = Res_utf8.decodeCodePoint scanner.offset scanner.src (String.length scanner.src) in - for _ = 0 to length - 1 do - next scanner - done; - if scanner.ch = '\'' then ( - let contents = (String.sub [@doesNotRaise]) scanner.src offset length in + let token = + match scanner.ch with + (* peeking 0 char *) + | 'A' .. 'Z' | 'a' .. 'z' -> scanIdentifier scanner + | '0' .. '9' -> scanNumber scanner + | '`' -> + next scanner; + Token.Backtick + | '~' -> + next scanner; + Token.Tilde + | '?' -> + next scanner; + Token.Question + | ';' -> + next scanner; + Token.Semicolon + | '(' -> + next scanner; + Token.Lparen + | ')' -> + next scanner; + Token.Rparen + | '[' -> + next scanner; + Token.Lbracket + | ']' -> + next scanner; + Token.Rbracket + | '{' -> + next scanner; + Token.Lbrace + | '}' -> + next scanner; + Token.Rbrace + | ',' -> + next scanner; + Token.Comma + | '"' -> scanString scanner + (* peeking 1 char *) + | '_' -> ( + match peek scanner with + | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> scanIdentifier scanner + | _ -> + next scanner; + Token.Underscore) + | '#' -> ( + match peek scanner with + | '=' -> + next2 scanner; + Token.HashEqual + | _ -> + next scanner; + Token.Hash) + | '*' -> ( + match peek scanner with + | '*' -> + next2 scanner; + Token.Exponentiation + | '.' -> + next2 scanner; + Token.AsteriskDot + | _ -> + next scanner; + Token.Asterisk) + | '@' -> ( + match peek scanner with + | '@' -> + next2 scanner; + Token.AtAt + | _ -> + next scanner; + Token.At) + | '%' -> ( + match peek scanner with + | '%' -> + next2 scanner; + Token.PercentPercent + | _ -> + next scanner; + Token.Percent) + | '|' -> ( + match peek scanner with + | '|' -> + next2 scanner; + Token.Lor + | '>' -> + next2 scanner; + Token.BarGreater + | _ -> + next scanner; + Token.Bar) + | '&' -> ( + match peek scanner with + | '&' -> + next2 scanner; + Token.Land + | _ -> + next scanner; + Token.Band) + | ':' -> ( + match peek scanner with + | '=' -> + next2 scanner; + Token.ColonEqual + | '>' -> + next2 scanner; + Token.ColonGreaterThan + | _ -> + next scanner; + Token.Colon) + | '\\' -> + next scanner; + scanExoticIdentifier scanner + | '/' -> ( + match peek scanner with + | '/' -> + next2 scanner; + scanSingleLineComment scanner + | '*' -> scanMultiLineComment scanner + | '.' -> + next2 scanner; + Token.ForwardslashDot + | _ -> + next scanner; + Token.Forwardslash) + | '-' -> ( + match peek scanner with + | '.' -> + next2 scanner; + Token.MinusDot + | '>' -> + next2 scanner; + Token.MinusGreater + | _ -> + next scanner; + Token.Minus) + | '+' -> ( + match peek scanner with + | '.' -> + next2 scanner; + Token.PlusDot + | '+' -> + next2 scanner; + Token.PlusPlus + | '=' -> + next2 scanner; + Token.PlusEqual + | _ -> + next scanner; + Token.Plus) + | '>' -> ( + match peek scanner with + | '=' when not (inDiamondMode scanner) -> + next2 scanner; + Token.GreaterEqual + | _ -> + next scanner; + Token.GreaterThan) + | '<' when not (inJsxMode scanner) -> ( + match peek scanner with + | '=' -> + next2 scanner; + Token.LessEqual + | _ -> + next scanner; + Token.LessThan) + (* special handling for JSX < *) + | '<' -> ( + (* Imagine the following:
< + * < indicates the start of a new jsx-element, the parser expects + * the name of a new element after the < + * Example:
+ * This signals a closing element. To simulate the two-token lookahead, + * the + next scanner; + Token.LessThanSlash + | '=' -> + next scanner; + Token.LessEqual + | _ -> Token.LessThan) + (* peeking 2 chars *) + | '.' -> ( + match (peek scanner, peek2 scanner) with + | '.', '.' -> + next3 scanner; + Token.DotDotDot + | '.', _ -> + next2 scanner; + Token.DotDot + | _ -> + next scanner; + Token.Dot) + | '\'' -> ( + match (peek scanner, peek2 scanner) with + | '\\', '"' -> + (* careful with this one! We're next-ing _once_ (not twice), + then relying on matching on the quote *) next scanner; - Token.Codepoint {c = Obj.magic codepoint; original = contents} - ) else ( - scanner.ch <- ch; - scanner.offset <- offset; SingleQuote - )) - | '!' -> - (match peek scanner, peek2 scanner with - | '=', '=' -> next3 scanner; Token.BangEqualEqual - | '=', _ -> next2 scanner; Token.BangEqual - | _ -> next scanner; Token.Bang) - | '=' -> - (match peek scanner, peek2 scanner with - | '=', '=' -> next3 scanner; Token.EqualEqualEqual - | '=', _ -> next2 scanner; Token.EqualEqual - | '>', _ -> next2 scanner; Token.EqualGreater - | _ -> next scanner; Token.Equal) - - (* special cases *) - | ch when ch == hackyEOFChar -> next scanner; Token.Eof - | ch -> - (* if we arrive here, we're dealing with an unknown character, - * report the error and continue scanning… *) - next scanner; - let endPos = position scanner in - scanner.err ~startPos ~endPos (Diagnostics.unknownUchar ch); - let (_, _, token) = scan scanner in - token + | '\\', _ -> + next2 scanner; + scanEscape scanner + | ch, '\'' -> + let offset = scanner.offset + 1 in + next3 scanner; + Token.Codepoint + {c = ch; original = (String.sub [@doesNotRaise]) scanner.src offset 1} + | ch, _ -> + next scanner; + let offset = scanner.offset in + let codepoint, length = + Res_utf8.decodeCodePoint scanner.offset scanner.src + (String.length scanner.src) + in + for _ = 0 to length - 1 do + next scanner + done; + if scanner.ch = '\'' then ( + let contents = + (String.sub [@doesNotRaise]) scanner.src offset length + in + next scanner; + Token.Codepoint {c = Obj.magic codepoint; original = contents}) + else ( + scanner.ch <- ch; + scanner.offset <- offset; + SingleQuote)) + | '!' -> ( + match (peek scanner, peek2 scanner) with + | '=', '=' -> + next3 scanner; + Token.BangEqualEqual + | '=', _ -> + next2 scanner; + Token.BangEqual + | _ -> + next scanner; + Token.Bang) + | '=' -> ( + match (peek scanner, peek2 scanner) with + | '=', '=' -> + next3 scanner; + Token.EqualEqualEqual + | '=', _ -> + next2 scanner; + Token.EqualEqual + | '>', _ -> + next2 scanner; + Token.EqualGreater + | _ -> + next scanner; + Token.Equal) + (* special cases *) + | ch when ch == hackyEOFChar -> + next scanner; + Token.Eof + | ch -> + (* if we arrive here, we're dealing with an unknown character, + * report the error and continue scanning… *) + next scanner; + let endPos = position scanner in + scanner.err ~startPos ~endPos (Diagnostics.unknownUchar ch); + let _, _, token = scan scanner in + token in let endPos = position scanner in (* _printDebug ~startPos ~endPos scanner token; *) (startPos, endPos, token) - (* misc helpers used elsewhere *) (* Imagine:
< @@ -734,46 +878,43 @@ let reconsiderLessThan scanner = if scanner.ch == '/' then let () = next scanner in Token.LessThanSlash - else - Token.LessThan + else Token.LessThan (* If an operator has whitespace around both sides, it's a binary operator *) (* TODO: this helper seems out of place *) let isBinaryOp src startCnum endCnum = if startCnum == 0 then false - else begin + else ( (* we're gonna put some assertions and invariant checks here because this is - used outside of the scanner's normal invariant assumptions *) + used outside of the scanner's normal invariant assumptions *) assert (endCnum >= 0); assert (startCnum > 0 && startCnum < String.length src); let leftOk = isWhitespace (String.unsafe_get src (startCnum - 1)) in (* we need some stronger confidence that endCnum is ok *) - let rightOk = endCnum >= String.length src || isWhitespace (String.unsafe_get src endCnum) in - leftOk && rightOk - end + let rightOk = + endCnum >= String.length src + || isWhitespace (String.unsafe_get src endCnum) + in + leftOk && rightOk) (* Assume `{` consumed, advances the scanner towards the ends of Reason quoted strings. (for conversion) * In {| foo bar |} the scanner will be advanced until after the `|}` *) let tryAdvanceQuotedString scanner = let rec scanContents tag = match scanner.ch with - | '|' -> + | '|' -> ( next scanner; - (match scanner.ch with - | 'a'..'z' -> + match scanner.ch with + | 'a' .. 'z' -> let startOff = scanner.offset in skipLowerCaseChars scanner; let suffix = - (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) - in begin - if tag = suffix then ( - if scanner.ch = '}' then - next scanner - else - scanContents tag - ) else - scanContents tag - end + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - startOff) + in + if tag = suffix then + if scanner.ch = '}' then next scanner else scanContents tag + else scanContents tag | '}' -> next scanner | _ -> scanContents tag) | ch when ch == hackyEOFChar -> @@ -784,11 +925,13 @@ let tryAdvanceQuotedString scanner = scanContents tag in match scanner.ch with - | 'a'..'z' -> + | 'a' .. 'z' -> let startOff = scanner.offset in skipLowerCaseChars scanner; - let tag = (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) in + let tag = + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - startOff) + in if scanner.ch = '|' then scanContents tag - | '|' -> - scanContents "" + | '|' -> scanContents "" | _ -> () diff --git a/src/res_scanner.mli b/src/res_scanner.mli index 777d171e..e68020cf 100644 --- a/src/res_scanner.mli +++ b/src/res_scanner.mli @@ -6,10 +6,10 @@ type t = { filename: string; src: string; mutable err: - startPos: Lexing.position - -> endPos: Lexing.position - -> Res_diagnostics.category - -> unit; + startPos:Lexing.position -> + endPos:Lexing.position -> + Res_diagnostics.category -> + unit; mutable ch: charEncoding; (* current character *) mutable offset: int; (* character offset *) mutable lineOffset: int; (* current line offset *) @@ -17,19 +17,20 @@ type t = { mutable mode: mode list; } -val make: filename:string -> string -> t +val make : filename:string -> string -> t (* TODO: make this a record *) -val scan: t -> (Lexing.position * Lexing.position * Res_token.t) +val scan : t -> Lexing.position * Lexing.position * Res_token.t -val isBinaryOp: string -> int -> int -> bool +val isBinaryOp : string -> int -> int -> bool -val setJsxMode: t -> unit -val setDiamondMode: t -> unit -val popMode: t -> mode -> unit +val setJsxMode : t -> unit +val setDiamondMode : t -> unit +val popMode : t -> mode -> unit -val reconsiderLessThan: t -> Res_token.t +val reconsiderLessThan : t -> Res_token.t -val scanTemplateLiteralToken: t -> (Lexing.position * Lexing.position * Res_token.t) +val scanTemplateLiteralToken : + t -> Lexing.position * Lexing.position * Res_token.t -val tryAdvanceQuotedString: t -> unit +val tryAdvanceQuotedString : t -> unit diff --git a/src/res_token.ml b/src/res_token.ml index 814e078e..e8901fcd 100644 --- a/src/res_token.ml +++ b/src/res_token.ml @@ -2,7 +2,8 @@ module Comment = Res_comment type t = | Open - | True | False + | True + | False | Codepoint of {c: char; original: string} | Int of {i: string; suffix: char option} | Float of {f: string; suffix: char option} @@ -10,7 +11,9 @@ type t = | Lident of string | Uident of string | As - | Dot | DotDot | DotDotDot + | Dot + | DotDot + | DotDotDot | Bang | Semicolon | Let @@ -18,7 +21,9 @@ type t = | Rec | Underscore | SingleQuote - | Equal | EqualEqual | EqualEqualEqual + | Equal + | EqualEqual + | EqualEqualEqual | Bar | Lparen | Rparen @@ -31,22 +36,36 @@ type t = | Eof | Exception | Backslash [@live] - | Forwardslash | ForwardslashDot - | Asterisk | AsteriskDot | Exponentiation - | Minus | MinusDot - | Plus | PlusDot | PlusPlus | PlusEqual + | Forwardslash + | ForwardslashDot + | Asterisk + | AsteriskDot + | Exponentiation + | Minus + | MinusDot + | Plus + | PlusDot + | PlusPlus + | PlusEqual | ColonGreaterThan | GreaterThan | LessThan | LessThanSlash - | Hash | HashEqual + | Hash + | HashEqual | Assert | Lazy | Tilde | Question - | If | Else | For | In | While | Switch + | If + | Else + | For + | In + | While + | Switch | When - | EqualGreater | MinusGreater + | EqualGreater + | MinusGreater | External | Typ | Private @@ -55,13 +74,18 @@ type t = | Include | Module | Of - | Land | Lor + | Land + | Lor | Band (* Bitwise and: & *) - | BangEqual | BangEqualEqual - | LessEqual | GreaterEqual + | BangEqual + | BangEqualEqual + | LessEqual + | GreaterEqual | ColonEqual - | At | AtAt - | Percent | PercentPercent + | At + | AtAt + | Percent + | PercentPercent | Comment of Comment.t | List | TemplateTail of string @@ -77,8 +101,9 @@ let precedence = function | HashEqual | ColonEqual -> 1 | Lor -> 2 | Land -> 3 - | Equal | EqualEqual | EqualEqualEqual | LessThan | GreaterThan - | BangEqual | BangEqualEqual | LessEqual | GreaterEqual | BarGreater -> 4 + | Equal | EqualEqual | EqualEqualEqual | LessThan | GreaterThan | BangEqual + | BangEqualEqual | LessEqual | GreaterEqual | BarGreater -> + 4 | Plus | PlusDot | Minus | MinusDot | PlusPlus -> 5 | Asterisk | AsteriskDot | Forwardslash | ForwardslashDot -> 6 | Exponentiation -> 7 @@ -88,12 +113,15 @@ let precedence = function let toString = function | Open -> "open" - | True -> "true" | False -> "false" + | True -> "true" + | False -> "false" | Codepoint {original} -> "codepoint '" ^ original ^ "'" | String s -> "string \"" ^ s ^ "\"" | Lident str -> str | Uident str -> str - | Dot -> "." | DotDot -> ".." | DotDotDot -> "..." + | Dot -> "." + | DotDot -> ".." + | DotDotDot -> "..." | Int {i} -> "int " ^ i | Float {f} -> "Float: " ^ f | Bang -> "!" @@ -103,26 +131,39 @@ let toString = function | Rec -> "rec" | Underscore -> "_" | SingleQuote -> "'" - | Equal -> "=" | EqualEqual -> "==" | EqualEqualEqual -> "===" + | Equal -> "=" + | EqualEqual -> "==" + | EqualEqualEqual -> "===" | Eof -> "eof" | Bar -> "|" | As -> "as" - | Lparen -> "(" | Rparen -> ")" - | Lbracket -> "[" | Rbracket -> "]" - | Lbrace -> "{" | Rbrace -> "}" + | Lparen -> "(" + | Rparen -> ")" + | Lbracket -> "[" + | Rbracket -> "]" + | Lbrace -> "{" + | Rbrace -> "}" | ColonGreaterThan -> ":>" | Colon -> ":" | Comma -> "," - | Minus -> "-" | MinusDot -> "-." - | Plus -> "+" | PlusDot -> "+." | PlusPlus -> "++" | PlusEqual -> "+=" + | Minus -> "-" + | MinusDot -> "-." + | Plus -> "+" + | PlusDot -> "+." + | PlusPlus -> "++" + | PlusEqual -> "+=" | Backslash -> "\\" - | Forwardslash -> "/" | ForwardslashDot -> "/." + | Forwardslash -> "/" + | ForwardslashDot -> "/." | Exception -> "exception" - | Hash -> "#" | HashEqual -> "#=" + | Hash -> "#" + | HashEqual -> "#=" | GreaterThan -> ">" | LessThan -> "<" | LessThanSlash -> " "*" | AsteriskDot -> "*." | Exponentiation -> "**" + | Asterisk -> "*" + | AsteriskDot -> "*." + | Exponentiation -> "**" | Assert -> "assert" | Lazy -> "lazy" | Tilde -> "tilde" @@ -134,7 +175,8 @@ let toString = function | While -> "while" | Switch -> "switch" | When -> "when" - | EqualGreater -> "=>" | MinusGreater -> "->" + | EqualGreater -> "=>" + | MinusGreater -> "->" | External -> "external" | Typ -> "type" | Private -> "private" @@ -144,13 +186,18 @@ let toString = function | Module -> "module" | Of -> "of" | Lor -> "||" - | Band -> "&" | Land -> "&&" - | BangEqual -> "!=" | BangEqualEqual -> "!==" - | GreaterEqual -> ">=" | LessEqual -> "<=" + | Band -> "&" + | Land -> "&&" + | BangEqual -> "!=" + | BangEqualEqual -> "!==" + | GreaterEqual -> ">=" + | LessEqual -> "<=" | ColonEqual -> ":=" - | At -> "@" | AtAt -> "@@" - | Percent -> "%" | PercentPercent -> "%%" - | Comment c -> "Comment" ^ (Comment.toString c) + | At -> "@" + | AtAt -> "@@" + | Percent -> "%" + | PercentPercent -> "%%" + | Comment c -> "Comment" ^ Comment.toString c | List -> "list{" | TemplatePart text -> text ^ "${" | TemplateTail text -> "TemplateTail(" ^ text ^ ")" @@ -162,54 +209,57 @@ let toString = function | DocComment (_loc, s) -> "DocComment " ^ s let keywordTable = function -| "and" -> And -| "as" -> As -| "assert" -> Assert -| "constraint" -> Constraint -| "else" -> Else -| "exception" -> Exception -| "export" -> Export -| "external" -> External -| "false" -> False -| "for" -> For -| "if" -> If -| "import" -> Import -| "in" -> In -| "include" -> Include -| "lazy" -> Lazy -| "let" -> Let -| "list{" -> List -| "module" -> Module -| "mutable" -> Mutable -| "of" -> Of -| "open" -> Open -| "private" -> Private -| "rec" -> Rec -| "switch" -> Switch -| "true" -> True -| "try" -> Try -| "type" -> Typ -| "when" -> When -| "while" -> While -| _ -> raise Not_found -[@@raises Not_found] + | "and" -> And + | "as" -> As + | "assert" -> Assert + | "constraint" -> Constraint + | "else" -> Else + | "exception" -> Exception + | "export" -> Export + | "external" -> External + | "false" -> False + | "for" -> For + | "if" -> If + | "import" -> Import + | "in" -> In + | "include" -> Include + | "lazy" -> Lazy + | "let" -> Let + | "list{" -> List + | "module" -> Module + | "mutable" -> Mutable + | "of" -> Of + | "open" -> Open + | "private" -> Private + | "rec" -> Rec + | "switch" -> Switch + | "true" -> True + | "try" -> Try + | "type" -> Typ + | "when" -> When + | "while" -> While + | _ -> raise Not_found + [@@raises Not_found] let isKeyword = function - | And | As | Assert | Constraint | Else | Exception | Export - | External | False | For | If | Import | In | Include | Land | Lazy - | Let | List | Lor | Module | Mutable | Of | Open | Private | Rec - | Switch | True | Try | Typ | When | While -> true + | And | As | Assert | Constraint | Else | Exception | Export | External + | False | For | If | Import | In | Include | Land | Lazy | Let | List | Lor + | Module | Mutable | Of | Open | Private | Rec | Switch | True | Try | Typ + | When | While -> + true | _ -> false let lookupKeyword str = - try keywordTable str with - | Not_found -> + try keywordTable str + with Not_found -> ( match str.[0] [@doesNotRaise] with - | 'A'..'Z' -> Uident str - | _ -> Lident str + | 'A' .. 'Z' -> Uident str + | _ -> Lident str) let isKeywordTxt str = - try let _ = keywordTable str in true with - | Not_found -> false + try + let _ = keywordTable str in + true + with Not_found -> false let catch = Lident "catch" diff --git a/src/res_utf8.ml b/src/res_utf8.ml index ab48ade3..69c7d234 100644 --- a/src/res_utf8.ml +++ b/src/res_utf8.ml @@ -24,11 +24,7 @@ let h4 = 0b1111_0000 let cont_mask = 0b0011_1111 -type category = { - low: int; - high: int; - size: int; -} +type category = {low: int; high: int; size: int} let locb = 0b1000_0000 let hicb = 0b1011_1111 @@ -67,74 +63,81 @@ let categories = [| |] [@@ocamlformat "disable"] let decodeCodePoint i s len = - if len < 1 then (repl, 1) else - let first = int_of_char (String.unsafe_get s i) in - if first < 128 then (first, 1) else - let index = Array.unsafe_get categories first in - if index = 0 then - (repl, 1) + if len < 1 then (repl, 1) else - let cat = Array.unsafe_get categoryTable index in - if len < i + cat.size then - (repl, 1) - else if cat.size == 2 then - let c1 = int_of_char (String.unsafe_get s (i + 1)) in - if c1 < cat.low || cat.high < c1 then - (repl, 1) - else - let i1 = c1 land 0b00111111 in - let i0 = (first land 0b00011111) lsl 6 in - let uc = i0 lor i1 in - (uc, 2) - else if cat.size == 3 then - let c1 = int_of_char (String.unsafe_get s (i + 1)) in - let c2 = int_of_char (String.unsafe_get s (i + 2)) in - if c1 < cat.low || cat.high < c1 || c2 < locb || hicb < c2 then (repl, 1) - else - let i0 = (first land 0b00001111) lsl 12 in - let i1 = (c1 land 0b00111111) lsl 6 in - let i2 = (c2 land 0b00111111) in - let uc = i0 lor i1 lor i2 in - (uc, 3) + let first = int_of_char (String.unsafe_get s i) in + if first < 128 then (first, 1) else - let c1 = int_of_char (String.unsafe_get s (i +1)) in - let c2 = int_of_char (String.unsafe_get s (i +2)) in - let c3 = int_of_char (String.unsafe_get s (i +3)) in - if c1 < cat.low || cat.high < c1 || - c2 < locb || hicb < c2 || c3 < locb || hicb < c3 - then (repl, 1) + let index = Array.unsafe_get categories first in + if index = 0 then (repl, 1) else - let i1 = (c1 land 0x3f) lsl 12 in - let i2 = (c2 land 0x3f) lsl 6 in - let i3 = (c3 land 0x3f) in - let i0 = (first land 0x07) lsl 18 in - let uc = i0 lor i3 lor i2 lor i1 in - (uc, 4) + let cat = Array.unsafe_get categoryTable index in + if len < i + cat.size then (repl, 1) + else if cat.size == 2 then + let c1 = int_of_char (String.unsafe_get s (i + 1)) in + if c1 < cat.low || cat.high < c1 then (repl, 1) + else + let i1 = c1 land 0b00111111 in + let i0 = (first land 0b00011111) lsl 6 in + let uc = i0 lor i1 in + (uc, 2) + else if cat.size == 3 then + let c1 = int_of_char (String.unsafe_get s (i + 1)) in + let c2 = int_of_char (String.unsafe_get s (i + 2)) in + if c1 < cat.low || cat.high < c1 || c2 < locb || hicb < c2 then + (repl, 1) + else + let i0 = (first land 0b00001111) lsl 12 in + let i1 = (c1 land 0b00111111) lsl 6 in + let i2 = c2 land 0b00111111 in + let uc = i0 lor i1 lor i2 in + (uc, 3) + else + let c1 = int_of_char (String.unsafe_get s (i + 1)) in + let c2 = int_of_char (String.unsafe_get s (i + 2)) in + let c3 = int_of_char (String.unsafe_get s (i + 3)) in + if + c1 < cat.low || cat.high < c1 || c2 < locb || hicb < c2 || c3 < locb + || hicb < c3 + then (repl, 1) + else + let i1 = (c1 land 0x3f) lsl 12 in + let i2 = (c2 land 0x3f) lsl 6 in + let i3 = c3 land 0x3f in + let i0 = (first land 0x07) lsl 18 in + let uc = i0 lor i3 lor i2 lor i1 in + (uc, 4) let encodeCodePoint c = if c <= 127 then ( let bytes = (Bytes.create [@doesNotRaise]) 1 in Bytes.unsafe_set bytes 0 (Char.unsafe_chr c); - Bytes.unsafe_to_string bytes - ) else if c <= 2047 then ( + Bytes.unsafe_to_string bytes) + else if c <= 2047 then ( let bytes = (Bytes.create [@doesNotRaise]) 2 in Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h2 lor (c lsr 6))); - Bytes.unsafe_set bytes 1 (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); - Bytes.unsafe_to_string bytes - ) else if c <= 65535 then ( + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else if c <= 65535 then ( let bytes = (Bytes.create [@doesNotRaise]) 3 in Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h3 lor (c lsr 12))); - Bytes.unsafe_set bytes 1 (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); - Bytes.unsafe_set bytes 2 (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); - Bytes.unsafe_to_string bytes - ) else (* if c <= max then *) ( + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else + (* if c <= max then *) let bytes = (Bytes.create [@doesNotRaise]) 4 in Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h4 lor (c lsr 18))); - Bytes.unsafe_set bytes 1 (Char.unsafe_chr (0b1000_0000 lor ((c lsr 12) land cont_mask))); - Bytes.unsafe_set bytes 2 (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); - Bytes.unsafe_set bytes 3 (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 12) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 3 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); Bytes.unsafe_to_string bytes - ) let isValidCodePoint c = - 0 <= c && c < surrogateMin || surrogateMax < c && c <= max + (0 <= c && c < surrogateMin) || (surrogateMax < c && c <= max) diff --git a/src/res_utf8.mli b/src/res_utf8.mli index 4b7462a4..7dcb342d 100644 --- a/src/res_utf8.mli +++ b/src/res_utf8.mli @@ -1,9 +1,9 @@ -val repl: int +val repl : int -val max: int +val max : int -val decodeCodePoint: int -> string -> int -> int * int +val decodeCodePoint : int -> string -> int -> int * int -val encodeCodePoint: int -> string +val encodeCodePoint : int -> string -val isValidCodePoint: int -> bool +val isValidCodePoint : int -> bool diff --git a/testrunner/res_test.ml b/testrunner/res_test.ml index 399a8769..07858f88 100644 --- a/testrunner/res_test.ml +++ b/testrunner/res_test.ml @@ -5,55 +5,53 @@ let () = let filename = "./tests/api/resSyntax.res" in let prettySource = Res_multi_printer.print `res ~input:filename in assert ( - prettySource = {|// test file + prettySource + = {|// test file if true { Js.log("true") } else { Js.log("false") } -|} - ) +|}) (* test printing of .resi file*) let () = let filename = "./tests/api/resiSyntax.resi" in let prettySource = Res_multi_printer.print `res ~input:filename in - assert ( - prettySource = {|// test interface file + assert (prettySource = {|// test interface file let x: int -|} - ) +|}) (* test printing of ocaml .ml file *) let () = let filename = "./tests/api/mlSyntax.ml" in let prettySource = Res_multi_printer.print `ml ~input:filename in assert ( - prettySource = {|/* test ml file */ + prettySource + = {|/* test ml file */ let () = print_endline("hello world") let unicode = "🙈 😅 🙌" let d = `Sehr Schön` -|} - ) +|}) (* test printing of ocaml .mli file *) let () = let filename = "./tests/api/mliSyntax.mli" in let prettySource = Res_multi_printer.print `ml ~input:filename in assert ( - prettySource = {|/* test mli file */ + prettySource + = {|/* test mli file */ let x: int /* comment */ let y: float -|} - ) +|}) let () = print_endline "✅ multi printer api tests" @@ -64,30 +62,31 @@ module OutcomePrinterTests = struct Compmisc.init_path false; Clflags.nopervasives := true; let env = Compmisc.initial_env () in - try ( - let (_typedStructure, signature, _newenv) = - Typemod.type_toplevel_phrase env structure in - signature - |> Printtyp.tree_of_signature - |> (!Oprint.out_signature) Format.str_formatter; - Format.flush_str_formatter() - ) with + try + let _typedStructure, signature, _newenv = + Typemod.type_toplevel_phrase env structure + in + signature |> Printtyp.tree_of_signature + |> !Oprint.out_signature Format.str_formatter; + Format.flush_str_formatter () + with | Typetexp.Error (_, _, err) -> Typetexp.report_error env Format.str_formatter err; prerr_string (Format.flush_str_formatter ()); - exit 1; + exit 1 | Typemod.Error (_, _, err) -> Typemod.report_error env Format.str_formatter err; prerr_string (Format.flush_str_formatter ()); - exit 1; + exit 1 | Typedecl.Error (_, err) -> Typedecl.report_error Format.str_formatter err; prerr_string (Format.flush_str_formatter ()); - exit 1; + exit 1 | e -> prerr_string - ("Unknown error while trying to print outcome tree.\n" ^ - "We don't display all the outcome type errors; try adding the new case to the `try` pattern match.\n"); + ("Unknown error while trying to print outcome tree.\n" + ^ "We don't display all the outcome type errors; try adding the new \ + case to the `try` pattern match.\n"); raise e (* `tests/oprint/oprint.res` will be read into memory and typechecked. @@ -97,23 +96,24 @@ module OutcomePrinterTests = struct * and stored in a snapshot `tests/oprint/expected/oprint.resi.txt` *) let run () = let filename = "tests/oprint/oprint.res" in - let result = Res_driver.parsingEngine.parseImplementation ~forPrinter:false ~filename in - let signature = if result.Res_driver.invalid then ( - Res_driver.parsingEngine.stringOfDiagnostics - ~source:(result.source) - ~filename:result.filename - result.diagnostics; - exit 1 - ) else - result.Res_driver.parsetree + let result = + Res_driver.parsingEngine.parseImplementation ~forPrinter:false ~filename + in + let signature = + if result.Res_driver.invalid then ( + Res_driver.parsingEngine.stringOfDiagnostics ~source:result.source + ~filename:result.filename result.diagnostics; + exit 1) + else result.Res_driver.parsetree in - IO.writeFile ~filename:"tests/oprint/expected/oprint.resi.txt" ~contents:(signatureToOutcome signature) + IO.writeFile ~filename:"tests/oprint/expected/oprint.resi.txt" + ~contents:(signatureToOutcome signature) end module ParserApiTest = struct let makeDefault () = let src = " let x = 1\nlet y = 2\nlet z = 3" in - let parser = Res_parser.make src "test.res" in + let parser = Res_parser.make src "test.res" in assert (parser.scanner.lnum == 1); assert (parser.scanner.lineOffset == 0); assert (parser.scanner.offset == 6); @@ -143,11 +143,11 @@ module ParserApiTest = struct print_endline "✅ Parser handles CRLF correct" let run () = - makeDefault(); - unixLf(); - windowsCrlf() + makeDefault (); + unixLf (); + windowsCrlf () end -let () = OutcomePrinterTests.run() -let () = ParserApiTest.run() -let () = Res_utf8_test.run() +let () = OutcomePrinterTests.run () +let () = ParserApiTest.run () +let () = Res_utf8_test.run () diff --git a/testrunner/res_utf8_test.ml b/testrunner/res_utf8_test.ml index 7d5172ce..5546ae3f 100644 --- a/testrunner/res_utf8_test.ml +++ b/testrunner/res_utf8_test.ml @@ -1,91 +1,93 @@ -type utf8Test = { - codepoint: int; - str: string; - size: int; -} +type utf8Test = {codepoint: int; str: string; size: int} -let utf8CodePointTests = [| - {codepoint = 0x00; str = "\x00"; size = 1}; - {codepoint = 0x01; str = "\x01"; size = 1}; - {codepoint = 0x7e; str = "\x7e"; size = 1}; - {codepoint = 0x7f; str = "\x7f"; size = 1}; - {codepoint = 0x0080; str = "\xc2\x80"; size = 2}; - {codepoint = 0x0081; str = "\xc2\x81"; size = 2}; - {codepoint = 0x00bf; str = "\xc2\xbf"; size = 2}; - {codepoint = 0x00c0; str = "\xc3\x80"; size = 2}; - {codepoint = 0x00c1; str = "\xc3\x81"; size = 2}; - {codepoint = 0x00c8; str = "\xc3\x88"; size = 2}; - {codepoint = 0x00d0; str = "\xc3\x90"; size = 2}; - {codepoint = 0x00e0; str = "\xc3\xa0"; size = 2}; - {codepoint = 0x00f0; str = "\xc3\xb0"; size = 2}; - {codepoint = 0x00f8; str = "\xc3\xb8"; size = 2}; - {codepoint = 0x00ff; str = "\xc3\xbf"; size = 2}; - {codepoint = 0x0100; str = "\xc4\x80"; size = 2}; - {codepoint = 0x07ff; str = "\xdf\xbf"; size = 2}; - {codepoint = 0x0400; str = "\xd0\x80"; size = 2}; - {codepoint = 0x0800; str = "\xe0\xa0\x80"; size = 3}; - {codepoint = 0x0801; str = "\xe0\xa0\x81"; size = 3}; - {codepoint = 0x1000; str = "\xe1\x80\x80"; size = 3}; - {codepoint = 0xd000; str = "\xed\x80\x80"; size = 3}; - {codepoint = 0xd7ff; str = "\xed\x9f\xbf"; size = 3}; - {codepoint = 0xe000; str = "\xee\x80\x80"; size = 3}; - {codepoint = 0xfffe; str = "\xef\xbf\xbe"; size = 3}; - {codepoint = 0xffff; str = "\xef\xbf\xbf"; size = 3}; - {codepoint = 0x10000; str = "\xf0\x90\x80\x80"; size = 4}; - {codepoint = 0x10001; str = "\xf0\x90\x80\x81"; size = 4}; - {codepoint = 0x40000; str = "\xf1\x80\x80\x80"; size = 4}; - {codepoint = 0x10fffe; str = "\xf4\x8f\xbf\xbe"; size = 4}; - {codepoint = 0x10ffff; str = "\xf4\x8f\xbf\xbf"; size = 4}; - {codepoint = 0xFFFD; str = "\xef\xbf\xbd"; size = 3} -|] +let utf8CodePointTests = + [| + {codepoint = 0x00; str = "\x00"; size = 1}; + {codepoint = 0x01; str = "\x01"; size = 1}; + {codepoint = 0x7e; str = "\x7e"; size = 1}; + {codepoint = 0x7f; str = "\x7f"; size = 1}; + {codepoint = 0x0080; str = "\xc2\x80"; size = 2}; + {codepoint = 0x0081; str = "\xc2\x81"; size = 2}; + {codepoint = 0x00bf; str = "\xc2\xbf"; size = 2}; + {codepoint = 0x00c0; str = "\xc3\x80"; size = 2}; + {codepoint = 0x00c1; str = "\xc3\x81"; size = 2}; + {codepoint = 0x00c8; str = "\xc3\x88"; size = 2}; + {codepoint = 0x00d0; str = "\xc3\x90"; size = 2}; + {codepoint = 0x00e0; str = "\xc3\xa0"; size = 2}; + {codepoint = 0x00f0; str = "\xc3\xb0"; size = 2}; + {codepoint = 0x00f8; str = "\xc3\xb8"; size = 2}; + {codepoint = 0x00ff; str = "\xc3\xbf"; size = 2}; + {codepoint = 0x0100; str = "\xc4\x80"; size = 2}; + {codepoint = 0x07ff; str = "\xdf\xbf"; size = 2}; + {codepoint = 0x0400; str = "\xd0\x80"; size = 2}; + {codepoint = 0x0800; str = "\xe0\xa0\x80"; size = 3}; + {codepoint = 0x0801; str = "\xe0\xa0\x81"; size = 3}; + {codepoint = 0x1000; str = "\xe1\x80\x80"; size = 3}; + {codepoint = 0xd000; str = "\xed\x80\x80"; size = 3}; + {codepoint = 0xd7ff; str = "\xed\x9f\xbf"; size = 3}; + {codepoint = 0xe000; str = "\xee\x80\x80"; size = 3}; + {codepoint = 0xfffe; str = "\xef\xbf\xbe"; size = 3}; + {codepoint = 0xffff; str = "\xef\xbf\xbf"; size = 3}; + {codepoint = 0x10000; str = "\xf0\x90\x80\x80"; size = 4}; + {codepoint = 0x10001; str = "\xf0\x90\x80\x81"; size = 4}; + {codepoint = 0x40000; str = "\xf1\x80\x80\x80"; size = 4}; + {codepoint = 0x10fffe; str = "\xf4\x8f\xbf\xbe"; size = 4}; + {codepoint = 0x10ffff; str = "\xf4\x8f\xbf\xbf"; size = 4}; + {codepoint = 0xFFFD; str = "\xef\xbf\xbd"; size = 3}; + |] -let surrogateRange = [| - {codepoint = 0xFFFD; str = "\xed\xa0\x80"; size = 1}; - {codepoint = 0xFFFD; str = "\xed\xbf\xbf"; size = 1}; -|] +let surrogateRange = + [| + {codepoint = 0xFFFD; str = "\xed\xa0\x80"; size = 1}; + {codepoint = 0xFFFD; str = "\xed\xbf\xbf"; size = 1}; + |] let testDecode () = - Array.iter (fun t -> - let len = String.length t.str in - let (codepoint, size) = Res_utf8.decodeCodePoint 0 t.str len in - assert (codepoint = t.codepoint); - assert (size = t.size) -) utf8CodePointTests + Array.iter + (fun t -> + let len = String.length t.str in + let codepoint, size = Res_utf8.decodeCodePoint 0 t.str len in + assert (codepoint = t.codepoint); + assert (size = t.size)) + utf8CodePointTests let testDecodeSurrogateRange () = - Array.iter (fun t -> - let len = String.length t.str in - let (codepoint, size) = Res_utf8.decodeCodePoint 0 t.str len in - assert (codepoint = t.codepoint); - assert (size = t.size) -) surrogateRange + Array.iter + (fun t -> + let len = String.length t.str in + let codepoint, size = Res_utf8.decodeCodePoint 0 t.str len in + assert (codepoint = t.codepoint); + assert (size = t.size)) + surrogateRange let testEncode () = - Array.iter (fun t -> - let encodedString = Res_utf8.encodeCodePoint t.codepoint in - assert (encodedString = t.str) -) utf8CodePointTests + Array.iter + (fun t -> + let encodedString = Res_utf8.encodeCodePoint t.codepoint in + assert (encodedString = t.str)) + utf8CodePointTests -let validCodePointsTests = [| - (0, true); - (Char.code 'e', true); - (Res_utf8.max, true); - (0xD7FF, true); - (0xD800, false); - (0xDFFF, false); - (0xE000, true); - (Res_utf8.max + 1, false); - (-1, false); -|] +let validCodePointsTests = + [| + (0, true); + (Char.code 'e', true); + (Res_utf8.max, true); + (0xD7FF, true); + (0xD800, false); + (0xDFFF, false); + (0xE000, true); + (Res_utf8.max + 1, false); + (-1, false); + |] let testIsValidCodePoint () = - Array.iter (fun (codePoint, t) -> - assert ((Res_utf8.isValidCodePoint codePoint) = t) - ) validCodePointsTests + Array.iter + (fun (codePoint, t) -> assert (Res_utf8.isValidCodePoint codePoint = t)) + validCodePointsTests let run () = - testDecode(); - testDecodeSurrogateRange(); - testEncode(); - testIsValidCodePoint(); + testDecode (); + testDecodeSurrogateRange (); + testEncode (); + testIsValidCodePoint (); print_endline "✅ utf8 tests"