From 18a5b9dc42dcbfdf26d4d692357a0b7a9b438932 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Mon, 26 Feb 2024 15:16:21 -0800 Subject: [PATCH] stop vendoring modules we don't need --- lambda/simplif.ml | 927 -------- lambda/simplif.mli | 40 - lib/melange_compiler_libs.ml | 21 - parsing/ast_helper.ml | 646 ------ parsing/ast_helper.mli | 497 ----- parsing/ast_iterator.ml | 697 ------ parsing/ast_iterator.mli | 84 - parsing/ast_mapper.ml | 1104 ---------- parsing/ast_mapper.mli | 208 -- parsing/attr_helper.ml | 54 - parsing/attr_helper.mli | 41 - parsing/depend.ml | 608 ------ parsing/depend.mli | 45 - parsing/docstrings.ml | 425 ---- parsing/docstrings.mli | 223 -- parsing/lexer.mli | 64 - parsing/lexer.mll | 869 -------- parsing/parse.ml | 155 -- parsing/parse.mli | 110 - parsing/parser.mly | 3904 ---------------------------------- parsing/parsetree.mli | 1067 ---------- parsing/pprintast.ml | 1677 --------------- parsing/pprintast.mli | 55 - parsing/printast.ml | 982 --------- parsing/printast.mli | 32 - parsing/syntaxerr.ml | 45 - parsing/syntaxerr.mli | 38 - typing/outcometree.mli | 155 -- typing/path.ml | 144 -- typing/path.mli | 80 - typing/type_immediacy.ml | 43 - typing/type_immediacy.mli | 40 - utils/consistbl.ml | 95 - utils/consistbl.mli | 77 - utils/diffing_with_keys.ml | 208 -- utils/diffing_with_keys.mli | 77 - utils/lazy_backtrack.ml | 87 - utils/lazy_backtrack.mli | 34 - utils/load_path.ml | 176 -- utils/load_path.mli | 96 - 40 files changed, 15930 deletions(-) delete mode 100644 lambda/simplif.ml delete mode 100644 lambda/simplif.mli delete mode 100644 parsing/ast_helper.ml delete mode 100644 parsing/ast_helper.mli delete mode 100644 parsing/ast_iterator.ml delete mode 100644 parsing/ast_iterator.mli delete mode 100644 parsing/ast_mapper.ml delete mode 100644 parsing/ast_mapper.mli delete mode 100644 parsing/attr_helper.ml delete mode 100644 parsing/attr_helper.mli delete mode 100644 parsing/depend.ml delete mode 100644 parsing/depend.mli delete mode 100644 parsing/docstrings.ml delete mode 100644 parsing/docstrings.mli delete mode 100644 parsing/lexer.mli delete mode 100644 parsing/lexer.mll delete mode 100644 parsing/parse.ml delete mode 100644 parsing/parse.mli delete mode 100644 parsing/parser.mly delete mode 100644 parsing/parsetree.mli delete mode 100644 parsing/pprintast.ml delete mode 100644 parsing/pprintast.mli delete mode 100644 parsing/printast.ml delete mode 100644 parsing/printast.mli delete mode 100644 parsing/syntaxerr.ml delete mode 100644 parsing/syntaxerr.mli delete mode 100644 typing/outcometree.mli delete mode 100644 typing/path.ml delete mode 100644 typing/path.mli delete mode 100644 typing/type_immediacy.ml delete mode 100644 typing/type_immediacy.mli delete mode 100644 utils/consistbl.ml delete mode 100644 utils/consistbl.mli delete mode 100644 utils/diffing_with_keys.ml delete mode 100644 utils/diffing_with_keys.mli delete mode 100644 utils/lazy_backtrack.ml delete mode 100644 utils/lazy_backtrack.mli delete mode 100644 utils/load_path.ml delete mode 100644 utils/load_path.mli diff --git a/lambda/simplif.ml b/lambda/simplif.ml deleted file mode 100644 index d7ebe2d83b..0000000000 --- a/lambda/simplif.ml +++ /dev/null @@ -1,927 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Elimination of useless Llet(Alias) bindings. - Also transform let-bound references into variables. *) - -open Asttypes -open Lambda -open Debuginfo.Scoped_location - -(* To transform let-bound references into variables *) - -exception Real_reference - -let rec eliminate_ref id = function - Lvar v as lam -> - if Ident.same v id then raise Real_reference else lam - | Lmutvar _ | Lconst _ as lam -> lam - | Lapply ap -> - Lapply{ap with ap_func = eliminate_ref id ap.ap_func; - ap_args = List.map (eliminate_ref id) ap.ap_args} - | Lfunction _ as lam -> - if Ident.Set.mem id (free_variables lam) - then raise Real_reference - else lam - | Llet(str, kind, v, e1, e2) -> - Llet(str, kind, v, eliminate_ref id e1, eliminate_ref id e2) - | Lmutlet(kind, v, e1, e2) -> - Lmutlet(kind, v, eliminate_ref id e1, eliminate_ref id e2) - | Lletrec(idel, e2) -> - Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel, - eliminate_ref id e2) - | Lprim(Pfield (0, _, _, _), [Lvar v], _) when Ident.same v id -> - Lmutvar id - | Lprim(Psetfield(0, _, _, _), [Lvar v; e], _) when Ident.same v id -> - Lassign(id, eliminate_ref id e) - | Lprim(Poffsetref delta, [Lvar v], loc) when Ident.same v id -> - Lassign(id, Lprim(Poffsetint delta, [Lmutvar id], loc)) - | Lprim(p, el, loc) -> - Lprim(p, List.map (eliminate_ref id) el, loc) - | Lswitch(e, sw, loc) -> - Lswitch(eliminate_ref id e, - {sw_numconsts = sw.sw_numconsts; - sw_consts = - List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_consts; - sw_numblocks = sw.sw_numblocks; - sw_blocks = - List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks; - sw_failaction = - Option.map (eliminate_ref id) sw.sw_failaction; sw_names = sw.sw_names }, - loc) - | Lstringswitch(e, sw, default, loc) -> - Lstringswitch - (eliminate_ref id e, - List.map (fun (s, e) -> (s, eliminate_ref id e)) sw, - Option.map (eliminate_ref id) default, loc) - | Lstaticraise (i,args) -> - Lstaticraise (i,List.map (eliminate_ref id) args) - | Lstaticcatch(e1, i, e2) -> - Lstaticcatch(eliminate_ref id e1, i, eliminate_ref id e2) - | Ltrywith(e1, v, e2) -> - Ltrywith(eliminate_ref id e1, v, eliminate_ref id e2) - | Lifthenelse(e1, e2, e3) -> - Lifthenelse(eliminate_ref id e1, - eliminate_ref id e2, - eliminate_ref id e3) - | Lsequence(e1, e2) -> - Lsequence(eliminate_ref id e1, eliminate_ref id e2) - | Lwhile(e1, e2) -> - Lwhile(eliminate_ref id e1, eliminate_ref id e2) - | Lfor(v, e1, e2, dir, e3) -> - Lfor(v, eliminate_ref id e1, eliminate_ref id e2, - dir, eliminate_ref id e3) - | Lassign(v, e) -> - Lassign(v, eliminate_ref id e) - | Lsend(k, m, o, el, loc) -> - Lsend(k, eliminate_ref id m, eliminate_ref id o, - List.map (eliminate_ref id) el, loc) - | Levent(l, ev) -> - Levent(eliminate_ref id l, ev) - | Lifused(v, e) -> - Lifused(v, eliminate_ref id e) - -(* Simplification of exits *) - -type exit = { - mutable count: int; - mutable max_depth: int; -} - -let simplify_exits lam = - - (* Count occurrences of (exit n ...) statements *) - let exits = Hashtbl.create 17 in - - let get_exit i = - try Hashtbl.find exits i - with Not_found -> {count = 0; max_depth = 0} - - and incr_exit i nb d = - match Hashtbl.find_opt exits i with - | Some r -> - r.count <- r.count + nb; - r.max_depth <- Int.max r.max_depth d - | None -> - let r = {count = nb; max_depth = d} in - Hashtbl.add exits i r - in - - let rec count ~try_depth = function - | (Lvar _| Lmutvar _ | Lconst _) -> () - | Lapply ap -> - count ~try_depth ap.ap_func; - List.iter (count ~try_depth) ap.ap_args - | Lfunction {body} -> count ~try_depth body - | Llet(_, _kind, _v, l1, l2) - | Lmutlet(_kind, _v, l1, l2) -> - count ~try_depth l2; count ~try_depth l1 - | Lletrec(bindings, body) -> - List.iter (fun (_v, l) -> count ~try_depth l) bindings; - count ~try_depth body - | Lprim(_p, ll, _) -> List.iter (count ~try_depth) ll - | Lswitch(l, sw, _loc) -> - count_default ~try_depth sw ; - count ~try_depth l; - List.iter (fun (_, l) -> count ~try_depth l) sw.sw_consts; - List.iter (fun (_, l) -> count ~try_depth l) sw.sw_blocks - | Lstringswitch(l, sw, d, _) -> - count ~try_depth l; - List.iter (fun (_, l) -> count ~try_depth l) sw; - begin match d with - | None -> () - | Some d -> match sw with - | []|[_] -> count ~try_depth d - | _ -> (* default will get replicated *) - count ~try_depth d; count ~try_depth d - end - | Lstaticraise (i,ls) -> - incr_exit i 1 try_depth; - List.iter (count ~try_depth) ls - | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) -> - (* i will be replaced by j in l1, so each occurrence of i in l1 - increases j's ref count *) - count ~try_depth l1 ; - let ic = get_exit i in - incr_exit j ic.count (Int.max try_depth ic.max_depth) - | Lstaticcatch(l1, (i,_), l2) -> - count ~try_depth l1; - (* If l1 does not contain (exit i), - l2 will be removed, so don't count its exits *) - if (get_exit i).count > 0 then - count ~try_depth l2 - | Ltrywith(l1, _v, l2) -> - count ~try_depth:(try_depth+1) l1; - count ~try_depth l2; - | Lifthenelse(l1, l2, l3) -> - count ~try_depth l1; - count ~try_depth l2; - count ~try_depth l3 - | Lsequence(l1, l2) -> count ~try_depth l1; count ~try_depth l2 - | Lwhile(l1, l2) -> count ~try_depth l1; count ~try_depth l2 - | Lfor(_, l1, l2, _dir, l3) -> - count ~try_depth l1; - count ~try_depth l2; - count ~try_depth l3 - | Lassign(_v, l) -> count ~try_depth l - | Lsend(_k, m, o, ll, _) -> List.iter (count ~try_depth) (m::o::ll) - | Levent(l, _) -> count ~try_depth l - | Lifused(_v, l) -> count ~try_depth l - - and count_default ~try_depth sw = match sw.sw_failaction with - | None -> () - | Some al -> - let nconsts = List.length sw.sw_consts - and nblocks = List.length sw.sw_blocks in - if - nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks - then begin (* default action will occur twice in native code *) - count ~try_depth al ; count ~try_depth al - end else begin (* default action will occur once *) - assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ; - count ~try_depth al - end - in - count ~try_depth:0 lam; - - (* - Second pass simplify ``catch body with (i ...) handler'' - - if (exit i ...) does not occur in body, suppress catch - - if (exit i ...) occurs exactly once in body, - substitute it with handler - - If handler is a single variable, replace (exit i ..) with it - Note: - In ``catch body with (i x1 .. xn) handler'' - Substituted expression is - let y1 = x1 and ... yn = xn in - handler[x1 <- y1 ; ... ; xn <- yn] - For the sake of preserving the uniqueness of bound variables. - (No alpha conversion of ``handler'' is presently needed, since - substitution of several ``(exit i ...)'' - occurs only when ``handler'' is a variable.) - *) - - let subst = Hashtbl.create 17 in - let rec simplif ~try_depth = function - | (Lvar _| Lmutvar _ | Lconst _) as l -> l - | Lapply ap -> - Lapply{ap with ap_func = simplif ~try_depth ap.ap_func; - ap_args = List.map (simplif ~try_depth) ap.ap_args} - | Lfunction{kind; params; return; body = l; attr; loc} -> - lfunction ~kind ~params ~return ~body:(simplif ~try_depth l) ~attr ~loc - | Llet(str, kind, v, l1, l2) -> - Llet(str, kind, v, simplif ~try_depth l1, simplif ~try_depth l2) - | Lmutlet(kind, v, l1, l2) -> - Lmutlet(kind, v, simplif ~try_depth l1, simplif ~try_depth l2) - | Lletrec(bindings, body) -> - Lletrec(List.map (fun (v, l) -> (v, simplif ~try_depth l)) bindings, - simplif ~try_depth body) - | Lprim(p, ll, loc) -> begin - let ll = List.map (simplif ~try_depth) ll in - match p, ll with - (* Simplify Obj.with_tag *) - | Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ }, - [Lconst (Const_base (Const_int tag, _)); - Lprim (Pmakeblock (_, tag_info, mut, shape), fields, loc)] -> - Lprim (Pmakeblock(tag, tag_info, mut, shape), fields, loc) - | Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ }, - [Lconst (Const_base (Const_int tag, _)); - Lconst (Const_block (_, tag_info, fields))] -> - Lconst (Const_block (tag, tag_info, fields)) - - | _ -> Lprim(p, ll, loc) - end - | Lswitch(l, sw, loc) -> - let new_l = simplif ~try_depth l - and new_consts = - List.map (fun (n, e) -> (n, simplif ~try_depth e)) sw.sw_consts - and new_blocks = - List.map (fun (n, e) -> (n, simplif ~try_depth e)) sw.sw_blocks - and new_fail = Option.map (simplif ~try_depth) sw.sw_failaction in - Lswitch - (new_l, - {sw with sw_consts = new_consts ; sw_blocks = new_blocks; - sw_failaction = new_fail}, - loc) - | Lstringswitch(l,sw,d,loc) -> - Lstringswitch - (simplif ~try_depth l,List.map (fun (s,l) -> s,simplif ~try_depth l) sw, - Option.map (simplif ~try_depth) d,loc) - | Lstaticraise (i,[]) as l -> - begin try - let _,handler = Hashtbl.find subst i in - handler - with - | Not_found -> l - end - | Lstaticraise (i,ls) -> - let ls = List.map (simplif ~try_depth) ls in - begin try - let xs,handler = Hashtbl.find subst i in - let ys = List.map (fun (x, k) -> Ident.rename x, k) xs in - let env = - List.fold_right2 - (fun (x, _) (y, _) env -> Ident.Map.add x y env) - xs ys Ident.Map.empty - in - (* The evaluation order for Lstaticraise arguments is currently - right-to-left in all backends. - To preserve this, we use fold_left2 instead of fold_right2 - (the first argument is inserted deepest in the expression, - so will be evaluated last). - *) - List.fold_left2 - (fun r (y, kind) l -> Llet (Strict, kind, y, l, r)) - (Lambda.rename env handler) ys ls - with - | Not_found -> Lstaticraise (i,ls) - end - | Lstaticcatch (l1,(i,[]),(Lstaticraise (_j,[]) as l2)) -> - Hashtbl.add subst i ([],simplif ~try_depth l2) ; - simplif ~try_depth l1 - | Lstaticcatch (l1,(i,xs),l2) -> - let {count; max_depth} = get_exit i in - if count = 0 then - (* Discard staticcatch: not matching exit *) - simplif ~try_depth l1 - else if - count = 1 && max_depth <= try_depth then begin - (* Inline handler if there is a single occurrence and it is not - nested within an inner try..with *) - assert(max_depth = try_depth); - Hashtbl.add subst i (xs,simplif ~try_depth l2); - simplif ~try_depth l1 - end else - Lstaticcatch (simplif ~try_depth l1, (i,xs), simplif ~try_depth l2) - | Ltrywith(l1, v, l2) -> - let l1 = simplif ~try_depth:(try_depth + 1) l1 in - Ltrywith(l1, v, simplif ~try_depth l2) - | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif ~try_depth l1, - simplif ~try_depth l2, simplif ~try_depth l3) - | Lsequence(l1, l2) -> Lsequence(simplif ~try_depth l1, simplif ~try_depth l2) - | Lwhile(l1, l2) -> Lwhile(simplif ~try_depth l1, simplif ~try_depth l2) - | Lfor(v, l1, l2, dir, l3) -> - Lfor(v, simplif ~try_depth l1, simplif ~try_depth l2, dir, - simplif ~try_depth l3) - | Lassign(v, l) -> Lassign(v, simplif ~try_depth l) - | Lsend(k, m, o, ll, loc) -> - Lsend(k, simplif ~try_depth m, simplif ~try_depth o, - List.map (simplif ~try_depth) ll, loc) - | Levent(l, ev) -> Levent(simplif ~try_depth l, ev) - | Lifused(v, l) -> Lifused (v,simplif ~try_depth l) - in - simplif ~try_depth:0 lam - -(* Compile-time beta-reduction of functions immediately applied: - Lapply(Lfunction(Curried, params, body), args, loc) -> - let paramN = argN in ... let param1 = arg1 in body - Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) -> - let paramN = argN in ... let param1 = arg1 in body - Assumes |args| = |params|. -*) - -let exact_application {kind; params; _} args = - let arity = List.length params in - Lambda.find_exact_application kind ~arity args - -let beta_reduce params body args = - List.fold_left2 (fun l (param, kind) arg -> Llet(Strict, kind, param, arg, l)) - body params args - -(* Simplification of lets *) - -let simplify_lets lam = - - (* Disable optimisations for bytecode compilation with -g flag *) - let optimize = !Clflags.native_code || not !Clflags.debug in - - (* First pass: count the occurrences of all let-bound identifiers *) - - let occ = (Hashtbl.create 83: (Ident.t, int ref) Hashtbl.t) in - (* The global table [occ] associates to each let-bound identifier - the number of its uses (as a reference): - - 0 if never used - - 1 if used exactly once in and not under a lambda or within a loop - - > 1 if used several times or under a lambda or within a loop. - The local table [bv] associates to each locally-let-bound variable - its reference count, as above. [bv] is enriched at let bindings - but emptied when crossing lambdas and loops. *) - - (* Current use count of a variable. *) - let count_var v = - try - !(Hashtbl.find occ v) - with Not_found -> - 0 - - (* Entering a [let]. Returns updated [bv]. *) - and bind_var bv v = - let r = ref 0 in - Hashtbl.add occ v r; - Ident.Map.add v r bv - - (* Record a use of a variable *) - and use_var bv v n = - try - let r = Ident.Map.find v bv in r := !r + n - with Not_found -> - (* v is not locally bound, therefore this is a use under a lambda - or within a loop. Increase use count by 2 -- enough so - that single-use optimizations will not apply. *) - try - let r = Hashtbl.find occ v in r := !r + 2 - with Not_found -> - (* Not a let-bound variable, ignore *) - () in - - let rec count bv = function - | Lconst _ -> () - | Lvar v -> - use_var bv v 1 - | Lmutvar _ -> () - | Lapply{ap_func = ll; ap_args = args} -> - let no_opt () = count bv ll; List.iter (count bv) args in - begin match ll with - | Lfunction lf when optimize -> - begin match exact_application lf args with - | None -> no_opt () - | Some exact_args -> - count bv (beta_reduce lf.params lf.body exact_args) - end - | _ -> no_opt () - end - | Lfunction {body} -> - count Ident.Map.empty body - | Llet(_str, _k, v, Lvar w, l2) when optimize -> - (* v will be replaced by w in l2, so each occurrence of v in l2 - increases w's refcount *) - count (bind_var bv v) l2; - use_var bv w (count_var v) - | Llet(str, _kind, v, l1, l2) -> - count (bind_var bv v) l2; - (* If v is unused, l1 will be removed, so don't count its variables *) - if str = Strict || count_var v > 0 then count bv l1 - | Lmutlet(_kind, _v, l1, l2) -> - count bv l1; - count bv l2 - | Lletrec(bindings, body) -> - List.iter (fun (_v, l) -> count bv l) bindings; - count bv body - | Lprim(_p, ll, _) -> List.iter (count bv) ll - | Lswitch(l, sw, _loc) -> - count_default bv sw ; - count bv l; - List.iter (fun (_, l) -> count bv l) sw.sw_consts; - List.iter (fun (_, l) -> count bv l) sw.sw_blocks - | Lstringswitch(l, sw, d, _) -> - count bv l ; - List.iter (fun (_, l) -> count bv l) sw ; - begin match d with - | Some d -> - begin match sw with - | []|[_] -> count bv d - | _ -> count bv d ; count bv d - end - | None -> () - end - | Lstaticraise (_i,ls) -> List.iter (count bv) ls - | Lstaticcatch(l1, _, l2) -> count bv l1; count bv l2 - | Ltrywith(l1, _v, l2) -> count bv l1; count bv l2 - | Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3 - | Lsequence(l1, l2) -> count bv l1; count bv l2 - | Lwhile(l1, l2) -> count Ident.Map.empty l1; count Ident.Map.empty l2 - | Lfor(_, l1, l2, _dir, l3) -> - count bv l1; count bv l2; count Ident.Map.empty l3 - | Lassign(_v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refcount *) - count bv l - | Lsend(_, m, o, ll, _) -> List.iter (count bv) (m::o::ll) - | Levent(l, _) -> count bv l - | Lifused(v, l) -> - if count_var v > 0 then count bv l - - and count_default bv sw = match sw.sw_failaction with - | None -> () - | Some al -> - let nconsts = List.length sw.sw_consts - and nblocks = List.length sw.sw_blocks in - if - nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks - then begin (* default action will occur twice in native code *) - count bv al ; count bv al - end else begin (* default action will occur once *) - assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ; - count bv al - end - in - count Ident.Map.empty lam; - - (* Second pass: remove Lalias bindings of unused variables, - and substitute the bindings of variables used exactly once. *) - - let subst = Hashtbl.create 83 in - -(* This (small) optimisation is always legal, it may uncover some - tail call later on. *) - - let mklet str kind v e1 e2 = - match e2 with - | Lvar w when optimize && Ident.same v w -> e1 - | _ -> Llet (str, kind,v,e1,e2) - in - - let mkmutlet kind v e1 e2 = - match e2 with - | Lmutvar w when optimize && Ident.same v w -> e1 - | _ -> Lmutlet (kind,v,e1,e2) - in - - let rec simplif = function - Lvar v as l -> - begin try - Hashtbl.find subst v - with Not_found -> - l - end - | Lmutvar _ | Lconst _ as l -> l - | Lapply ({ap_func = ll; ap_args = args} as ap) -> - let no_opt () = - Lapply {ap with ap_func = simplif ap.ap_func; - ap_args = List.map simplif ap.ap_args} in - begin match ll with - | Lfunction lf when optimize -> - begin match exact_application lf args with - | None -> no_opt () - | Some exact_args -> - simplif (beta_reduce lf.params lf.body exact_args) - end - | _ -> no_opt () - end - | Lfunction{kind; params; return=return1; body = l; attr; loc} -> - begin match simplif l with - Lfunction{kind=Curried; params=params'; return=return2; body; attr; loc} - when kind = Curried && optimize && - List.length params + List.length params' <= Lambda.max_arity() -> - (* The return type is the type of the value returned after - applying all the parameters to the function. The return - type of the merged function taking [params @ params'] as - parameters is the type returned after applying [params']. *) - let return = return2 in - lfunction ~kind ~params:(params @ params') ~return ~body ~attr ~loc - | body -> - lfunction ~kind ~params ~return:return1 ~body ~attr ~loc - end - | Llet(_str, _k, v, Lvar w, l2) when optimize -> - Hashtbl.add subst v (simplif (Lvar w)); - simplif l2 - | Llet(Strict, kind, v, - Lprim(Pmakeblock(0, _, Mutable, kind_ref) as prim, [linit], loc), lbody) - when optimize -> - let slinit = simplif linit in - let slbody = simplif lbody in - begin try - let kind = match kind_ref with - | None -> Pgenval - | Some [field_kind] -> field_kind - | Some _ -> assert false - in - mkmutlet kind v slinit (eliminate_ref v slbody) - with Real_reference -> - mklet Strict kind v (Lprim(prim, [slinit], loc)) slbody - end - | Llet(Alias, kind, v, l1, l2) -> - begin match count_var v with - 0 -> simplif l2 - | 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2 - | _ -> Llet(Alias, kind, v, simplif l1, simplif l2) - end - | Llet(StrictOpt, kind, v, l1, l2) -> - begin match count_var v with - 0 -> simplif l2 - | _ -> mklet StrictOpt kind v (simplif l1) (simplif l2) - end - | Llet(str, kind, v, l1, l2) -> mklet str kind v (simplif l1) (simplif l2) - | Lmutlet(kind, v, l1, l2) -> mkmutlet kind v (simplif l1) (simplif l2) - | Lletrec(bindings, body) -> - Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) - | Lprim(p, ll, loc) -> Lprim(p, List.map simplif ll, loc) - | Lswitch(l, sw, loc) -> - let new_l = simplif l - and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts - and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = Option.map simplif sw.sw_failaction in - Lswitch - (new_l, - {sw with sw_consts = new_consts ; sw_blocks = new_blocks; - sw_failaction = new_fail}, - loc) - | Lstringswitch (l,sw,d,loc) -> - Lstringswitch - (simplif l,List.map (fun (s,l) -> s,simplif l) sw, - Option.map simplif d,loc) - | Lstaticraise (i,ls) -> - Lstaticraise (i, List.map simplif ls) - | Lstaticcatch(l1, (i,args), l2) -> - Lstaticcatch (simplif l1, (i,args), simplif l2) - | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2) - | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3) - | Lsequence(Lifused(v, l1), l2) -> - if count_var v > 0 - then Lsequence(simplif l1, simplif l2) - else simplif l2 - | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2) - | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2) - | Lfor(v, l1, l2, dir, l3) -> - Lfor(v, simplif l1, simplif l2, dir, simplif l3) - | Lassign(v, l) -> Lassign(v, simplif l) - | Lsend(k, m, o, ll, loc) -> - Lsend(k, simplif m, simplif o, List.map simplif ll, loc) - | Levent(l, ev) -> Levent(simplif l, ev) - | Lifused(v, l) -> - if count_var v > 0 then simplif l else lambda_unit - in - simplif lam - -(* Tail call info in annotation files *) - -let rec emit_tail_infos is_tail lambda = - match lambda with - | Lvar _ -> () - | Lmutvar _ -> () - | Lconst _ -> () - | Lapply ap -> - begin - (* Note: is_tail does not take backend-specific logic into - account (maximum number of parameters, etc.) so it may - over-approximate tail-callness. - - Trying to do something more fine-grained would result in - different warnings depending on whether the native or - bytecode compiler is used. *) - let maybe_warn ~is_tail ~expect_tail = - if is_tail <> expect_tail then () in - (* Location.prerr_warning (to_location ap.ap_loc) *) - (* (Warnings.Wrong_tailcall_expectation expect_tail) in *) - match ap.ap_tailcall with - | Default_tailcall -> () - | Tailcall_expectation expect_tail -> - maybe_warn ~is_tail ~expect_tail - end; - emit_tail_infos false ap.ap_func; - list_emit_tail_infos false ap.ap_args - | Lfunction {body = lam} -> - emit_tail_infos true lam - | Llet (_, _k, _, lam, body) - | Lmutlet (_k, _, lam, body) -> - emit_tail_infos false lam; - emit_tail_infos is_tail body - | Lletrec (bindings, body) -> - List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings; - emit_tail_infos is_tail body - | Lprim ((Pbytes_to_string | Pbytes_of_string), [arg], _) -> - emit_tail_infos is_tail arg - | Lprim (Psequand, [arg1; arg2], _) - | Lprim (Psequor, [arg1; arg2], _) -> - emit_tail_infos false arg1; - emit_tail_infos is_tail arg2 - | Lprim (_, l, _) -> - list_emit_tail_infos false l - | Lswitch (lam, sw, _loc) -> - emit_tail_infos false lam; - list_emit_tail_infos_fun snd is_tail sw.sw_consts; - list_emit_tail_infos_fun snd is_tail sw.sw_blocks; - Option.iter (emit_tail_infos is_tail) sw.sw_failaction - | Lstringswitch (lam, sw, d, _) -> - emit_tail_infos false lam; - List.iter - (fun (_,lam) -> emit_tail_infos is_tail lam) - sw ; - Option.iter (emit_tail_infos is_tail) d - | Lstaticraise (_, l) -> - list_emit_tail_infos false l - | Lstaticcatch (body, _, handler) -> - emit_tail_infos is_tail body; - emit_tail_infos is_tail handler - | Ltrywith (body, _, handler) -> - emit_tail_infos false body; - emit_tail_infos is_tail handler - | Lifthenelse (cond, ifso, ifno) -> - emit_tail_infos false cond; - emit_tail_infos is_tail ifso; - emit_tail_infos is_tail ifno - | Lsequence (lam1, lam2) -> - emit_tail_infos false lam1; - emit_tail_infos is_tail lam2 - | Lwhile (cond, body) -> - emit_tail_infos false cond; - emit_tail_infos false body - | Lfor (_, low, high, _, body) -> - emit_tail_infos false low; - emit_tail_infos false high; - emit_tail_infos false body - | Lassign (_, lam) -> - emit_tail_infos false lam - | Lsend (_, meth, obj, args, _loc) -> - emit_tail_infos false meth; - emit_tail_infos false obj; - list_emit_tail_infos false args - | Levent (lam, _) -> - emit_tail_infos is_tail lam - | Lifused (_, lam) -> - emit_tail_infos is_tail lam -and list_emit_tail_infos_fun f is_tail = - List.iter (fun x -> emit_tail_infos is_tail (f x)) -and list_emit_tail_infos is_tail = - List.iter (emit_tail_infos is_tail) - -(* Split a function with default parameters into a wrapper and an - inner function. The wrapper fills in missing optional parameters - with their default value and tail-calls the inner function. The - wrapper can then hopefully be inlined on most call sites to avoid - the overhead associated with boxing an optional argument with a - 'Some' constructor, only to deconstruct it immediately in the - function's body. *) - -let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc = - let rec aux map = function - (* When compiling [fun ?(x=expr) -> body], this is first translated - to: - [fun *opt* -> - let x = - match *opt* with - | None -> expr - | Some *sth* -> *sth* - in - body] - We want to detect the let binding to put it into the wrapper instead of - the inner function. - We need to find which optional parameter the binding corresponds to, - which is why we need a deep pattern matching on the expected result of - the pattern-matching compiler for options. - *) - | Llet(Strict, k, id, - (Lifthenelse(Lprim (Pisint, [Lvar optparam], _), _, _) as def), - rest) when - Ident.name optparam = "*opt*" && List.mem_assoc optparam params - && not (List.mem_assoc optparam map) - -> - let wrapper_body, inner = aux ((optparam, id) :: map) rest in - Llet(Strict, k, id, def, wrapper_body), inner - | _ when map = [] -> raise Exit - | body -> - (* Check that those *opt* identifiers don't appear in the remaining - body. This should not appear, but let's be on the safe side. *) - let fv = Lambda.free_variables body in - List.iter (fun (id, _) -> if Ident.Set.mem id fv then raise Exit) map; - - let inner_id = Ident.create_local (Ident.name fun_id ^ "_inner") in - let map_param p = try List.assoc p map with Not_found -> p in - let args = List.map (fun (p, _) -> Lvar (map_param p)) params in - let wrapper_body = - Lapply { - ap_func = Lvar inner_id; - ap_args = args; - ap_loc = Loc_unknown; - ap_tailcall = Default_tailcall; - ap_inlined = Default_inline; - ap_specialised = Default_specialise; - } - in - let inner_params = List.map map_param (List.map fst params) in - let new_ids = List.map Ident.rename inner_params in - let subst = - List.fold_left2 (fun s id new_id -> - Ident.Map.add id new_id s - ) Ident.Map.empty inner_params new_ids - in - let body = Lambda.rename subst body in - let inner_fun = - lfunction ~kind:Curried - ~params:(List.map (fun id -> id, Pgenval) new_ids) - ~return ~body ~attr ~loc - in - (wrapper_body, (inner_id, inner_fun)) - in - try - let body, inner = aux [] body in - let attr = default_stub_attribute in - [(fun_id, lfunction ~kind ~params ~return ~body ~attr ~loc); inner] - with Exit -> - [(fun_id, lfunction ~kind ~params ~return ~body ~attr ~loc)] - -(* Simplify local let-bound functions: if all occurrences are - fully-applied function calls in the same "tail scope", replace the - function by a staticcatch handler (on that scope). - - This handles as a special case functions used exactly once (in any - scope) for a full application. -*) - -type slot = - { - func: lfunction; - function_scope: lambda; - mutable scope: lambda option; - } - -module LamTbl = Hashtbl.Make(struct - type t = lambda - let equal = (==) - let hash = Hashtbl.hash - end) - -let simplify_local_functions lam = - let slots = Hashtbl.create 16 in - let static_id = Hashtbl.create 16 in (* function id -> static id *) - let static = LamTbl.create 16 in (* scope -> static function on that scope *) - (* We keep track of the current "tail scope", identified - by the outermost lambda for which the the current lambda - is in tail position. *) - let current_scope = ref lam in - (* PR11383: We will only apply the transformation if we don't have to move - code across function boundaries *) - let current_function_scope = ref lam in - let check_static lf = - if lf.attr.local = Always_local then - Location.prerr_warning (to_location lf.loc) - (Warnings.Inlining_impossible - "This function cannot be compiled into a static continuation") - in - let enabled = function - | {local = Always_local; _} - | {local = Default_local; inline = (Never_inline | Default_inline); _} - -> true - | {local = Default_local; - inline = (Always_inline | Unroll _ | Hint_inline); _} - | {local = Never_local; _} - -> false - in - let rec tail = function - | Llet (_str, _kind, id, Lfunction lf, cont) when enabled lf.attr -> - let r = - { func = lf; - function_scope = !current_function_scope; - scope = None } - in - Hashtbl.add slots id r; - tail cont; - begin match Hashtbl.find_opt slots id with - | Some {scope = Some scope; _} -> - let st = next_raise_count () in - let sc = - (* Do not move higher than current lambda *) - if scope == !current_scope then cont - else scope - in - Hashtbl.add static_id id st; - LamTbl.add static sc (st, lf); - (* The body of the function will become an handler - in that "scope". *) - with_scope ~scope lf.body - | _ -> - check_static lf; - (* note: if scope = None, the function is unused *) - function_definition lf - end - | Lapply {ap_func = Lvar id; ap_args; _} -> - begin match Hashtbl.find_opt slots id with - | Some {func; _} - when exact_application func ap_args = None -> - (* Wrong arity *) - Hashtbl.remove slots id - | Some {scope = Some scope; _} when scope != !current_scope -> - (* Different "tail scope" *) - Hashtbl.remove slots id - | Some {function_scope = fscope; _} - when fscope != !current_function_scope -> - (* Non local function *) - Hashtbl.remove slots id - | Some ({scope = None; _} as slot) -> - (* First use of the function: remember the current tail scope *) - slot.scope <- Some !current_scope - | _ -> - () - end; - List.iter non_tail ap_args - | Lvar id -> - Hashtbl.remove slots id - | Lfunction lf -> - check_static lf; - function_definition lf - | lam -> - Lambda.shallow_iter ~tail ~non_tail lam - and non_tail lam = - with_scope ~scope:lam lam - and function_definition lf = - let old_function_scope = !current_function_scope in - current_function_scope := lf.body; - non_tail lf.body; - current_function_scope := old_function_scope - and with_scope ~scope lam = - let old_scope = !current_scope in - current_scope := scope; - tail lam; - current_scope := old_scope - in - tail lam; - let rec rewrite lam0 = - let lam = - match lam0 with - | Llet (_, _, id, _, cont) when Hashtbl.mem static_id id -> - rewrite cont - | Lapply {ap_func = Lvar id; ap_args; _} when Hashtbl.mem static_id id -> - let st = Hashtbl.find static_id id in - let slot = Hashtbl.find slots id in - begin match exact_application slot.func ap_args with - | None -> assert false - | Some exact_args -> - Lstaticraise (st, List.map rewrite exact_args) - end - | lam -> - Lambda.shallow_map rewrite lam - in - List.fold_right - (fun (st, lf) lam -> - Lstaticcatch (lam, (st, lf.params), rewrite lf.body) - ) - (LamTbl.find_all static lam0) - lam - in - if LamTbl.length static = 0 then - lam - else - rewrite lam - -(* The entry point: - simplification - + rewriting of tail-modulo-cons calls - + emission of tailcall annotations, if needed -*) - -let simplify_lambda lam = - let lam = - lam - |> (if !Clflags.native_code || not !Clflags.debug - then simplify_local_functions else Fun.id - ) - |> simplify_exits - |> simplify_lets - |> Tmc.rewrite - in - if !Clflags.annotations - (* || Warnings.is_active (Warnings.Wrong_tailcall_expectation true) *) - then emit_tail_infos true lam; - lam diff --git a/lambda/simplif.mli b/lambda/simplif.mli deleted file mode 100644 index 2e5be0acca..0000000000 --- a/lambda/simplif.mli +++ /dev/null @@ -1,40 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Lambda simplification. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -(* Elimination of useless Llet(Alias) bindings. - Transformation of let-bound references into variables. - Simplification over staticraise/staticcatch constructs. - Generation of tail-call annotations if -annot is set. *) - -open Lambda - -val simplify_lambda: lambda -> lambda - -val split_default_wrapper - : id:Ident.t - -> kind:function_kind - -> params:(Ident.t * Lambda.value_kind) list - -> return:Lambda.value_kind - -> body:lambda - -> attr:function_attribute - -> loc:Lambda.scoped_location - -> (Ident.t * lambda) list diff --git a/lib/melange_compiler_libs.ml b/lib/melange_compiler_libs.ml index 079cc55216..f9ae3ee46f 100644 --- a/lib/melange_compiler_libs.ml +++ b/lib/melange_compiler_libs.ml @@ -4,23 +4,14 @@ *) module Annot = Annot -module Ast_helper = Ast_helper -module Ast_iterator = Ast_iterator -module Ast_mapper = Ast_mapper -module Attr_helper = Attr_helper module Bs_clflags = Bs_clflags module Btype = Btype module Builtin_attributes = Builtin_attributes module Cmi_format = Cmi_format module Cmt_format = Cmt_format module Config = Config -module Consistbl = Consistbl module Ctype = Ctype module Datarepr = Datarepr -module Depend = Depend -module Diffing = Diffing -module Diffing_with_keys = Diffing_with_keys -module Docstrings = Docstrings module Env = Env module Envaux = Envaux module Errortrace = Errortrace @@ -29,23 +20,14 @@ module Includecore = Includecore module Includemod = Includemod module Includemod_errorprinter = Includemod_errorprinter module Lambda = Lambda -module Lazy_backtrack = Lazy_backtrack -module Lexer = Lexer -module Load_path = Load_path module Location = Location module Matching = Matching module Misc = Misc module Mtype = Mtype module Oprint = Oprint -module Outcometree = Outcometree module Parmatch = Parmatch -module Parse = Parse -module Parser = Parser -module Parsetree = Parsetree -module Path = Path module Patterns = Patterns module Persistent_env = Persistent_env -module Pprintast = Pprintast module Predef = Predef module Primitive = Primitive module Printast = Printast @@ -55,9 +37,7 @@ module Printtyp = Printtyp module Printtyped = Printtyped module Rec_check = Rec_check module Shape = Shape -module Syntaxerr = Syntaxerr module Signature_group = Signature_group -module Simplif = Simplif module Stypes = Stypes module Subst = Subst module Switch = Switch @@ -70,7 +50,6 @@ module Translcore = Translcore module Translmod = Translmod module Translobj = Translobj module Translprim = Translprim -module Type_immediacy = Type_immediacy module Typeclass = Typeclass module Typecore = Typecore module Typedecl = Typedecl diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml deleted file mode 100644 index e99def77bf..0000000000 --- a/parsing/ast_helper.ml +++ /dev/null @@ -1,646 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Helpers to produce Parsetree fragments *) - -open Asttypes -open Parsetree -open Docstrings - -type 'a with_loc = 'a Location.loc -type loc = Location.t - -type lid = Longident.t with_loc -type str = string with_loc -type str_opt = string option with_loc -type attrs = attribute list - -let default_loc = ref Location.none - -let with_default_loc l f = - Misc.protect_refs [Misc.R (default_loc, l)] f - -module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (Int.to_string i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter ?(loc= !default_loc) s = - Pconst_string (s, loc, quotation_delimiter) -end - -module Attr = struct - let mk ?(loc= !default_loc) name payload = - { attr_name = name; - attr_payload = payload; - attr_loc = loc } -end - -module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; - ptyp_loc = loc; - ptyp_loc_stack = []; - ptyp_attributes = attrs} - - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - - let varify_constructors var_names t = - let check_variable vl loc v = - if List.mem v vl then - raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in - let var_names = List.map (fun v -> v.txt) var_names in - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> - check_variable var_names t.ptyp_loc x; - Ptyp_var x - | Ptyp_arrow (label,core_type,core_type') -> - Ptyp_arrow(label, loop core_type, loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr( { txt = Longident.Lident s }, []) - when List.mem s var_names -> - Ptyp_var s - | Ptyp_constr(longident, lst) -> - Ptyp_constr(longident, List.map loop lst) - | Ptyp_object (lst, o) -> - Ptyp_object (List.map loop_object_field lst, o) - | Ptyp_class (longident, lst) -> - Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) - in - {t with ptyp_desc = desc} - and loop_row_field field = - let prf_desc = match field.prf_desc with - | Rtag(label,flag,lst) -> - Rtag(label,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - in - { field with prf_desc; } - and loop_object_field field = - let pof_desc = match field.pof_desc with - | Otag(label, t) -> - Otag(label, loop t) - | Oinherit t -> - Oinherit (loop t) - in - { field with pof_desc; } - in - loop t - -end - -module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; - ppat_loc = loc; - ppat_loc_stack = []; - ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) -end - -module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b)) - let letop ?loc ?attrs let_ ands body = - mk ?loc ?attrs (Pexp_letop {let_; ands; body}) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - - let binding_op op pat exp loc = - { - pbop_op = op; - pbop_pat = pat; - pbop_exp = exp; - pbop_loc = loc; - } -end - -module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) -end - -module Mod = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg body = - mk ?loc ?attrs (Pmod_functor (arg, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let apply_unit ?loc ?attrs m1 = mk ?loc ?attrs (Pmod_apply_unit m1) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) -end - -module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_subst ?loc a = mk ?loc (Psig_typesubst a) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let mod_subst ?loc a = mk ?loc (Psig_modsubst a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let modtype_subst ?loc a = mk ?loc (Psig_modtypesubst a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt -end - -module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt -end - -module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b)) -end - -module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b)) -end - -module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - -end - -module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - -end - -module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } -end - -module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } -end - -module Ms = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name syn = - { - pms_name = name; - pms_manifest = syn; - pms_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pms_loc = loc; - } -end - -module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } -end - -module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } -end - -module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) expr = - { - popen_expr = expr; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } -end - -module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - -end - -module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) ?value_constraint pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_constraint=value_constraint; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } -end - -module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } -end - -module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(vars = []) ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_vars = vars; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - -end - -(** Type extensions *) -module Te = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_loc = loc; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - constructor = - { - ptyexn_constructor = constructor; - ptyexn_loc = loc; - ptyexn_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(vars = []) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(vars, args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - -end - -module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } -end - -module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } -end - -(** Row fields *) -module Rf = struct - let mk ?(loc = !default_loc) ?(attrs = []) desc = { - prf_desc = desc; - prf_loc = loc; - prf_attributes = attrs; - } - let tag ?loc ?attrs label const tys = - mk ?loc ?attrs (Rtag (label, const, tys)) - let inherit_?loc ty = - mk ?loc (Rinherit ty) -end - -(** Object fields *) -module Of = struct - let mk ?(loc = !default_loc) ?(attrs=[]) desc = { - pof_desc = desc; - pof_loc = loc; - pof_attributes = attrs; - } - let tag ?loc ?attrs label ty = - mk ?loc ?attrs (Otag (label, ty)) - let inherit_ ?loc ty = - mk ?loc (Oinherit ty) -end diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli deleted file mode 100644 index 07cb87c7b9..0000000000 --- a/parsing/ast_helper.mli +++ /dev/null @@ -1,497 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Helpers to produce Parsetree fragments - - {b Warning} This module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Asttypes -open Docstrings -open Parsetree - -type 'a with_loc = 'a Location.loc -type loc = Location.t - -type lid = Longident.t with_loc -type str = string with_loc -type str_opt = string option with_loc -type attrs = attribute list - -(** {1 Default locations} *) - -val default_loc: loc ref - (** Default value for all optional location arguments. *) - -val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - -(** {1 Constants} *) - -module Const : sig - val char : char -> constant - val string : - ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant -end - -(** {1 Attributes} *) -module Attr : sig - val mk: ?loc:loc -> str -> payload -> attribute -end - -(** {1 Core language} *) - -(** Type expressions *) -module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - -(** Patterns *) -module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> - lid -> (str list * pattern) option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - -(** Expressions *) -module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr - -> expression -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression - -> expression - val letop: ?loc:loc -> ?attrs:attrs -> binding_op - -> binding_op list -> expression -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - val binding_op: str -> pattern -> expression -> loc -> binding_op - end - -(** Value declarations *) -module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - -(** Type declarations *) -module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * (variance * injectivity)) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> - str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - -(** Type extensions *) -module Te: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * (variance * injectivity)) list -> - ?priv:private_flag -> lid -> extension_constructor list -> type_extension - - val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - extension_constructor -> type_exception - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> - str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - -(** {1 Module language} *) - -(** Module type expressions *) -module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - -(** Module expressions *) -module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val apply_unit: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - -(** Signature items *) -module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_subst: ?loc:loc -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> type_exception -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val mod_subst: ?loc:loc -> module_substitution -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val modtype_subst: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - -(** Structure items *) -module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> type_exception -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_declaration -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - -(** Module declarations *) -module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_type -> module_declaration - end - -(** Module substitutions *) -module Ms: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> lid -> module_substitution - end - -(** Module type declarations *) -module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - -(** Module bindings *) -module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_expr -> module_binding - end - -(** Opens *) -module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> 'a -> 'a open_infos - end - -(** Includes *) -module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - -(** Value bindings *) -module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?value_constraint:value_constraint -> pattern -> expression -> - value_binding - end - - -(** {1 Class language} *) - -(** Class type expressions *) -module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type - -> class_type - end - -(** Class type fields *) -module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - -(** Class expressions *) -module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr - -> class_expr - end - -(** Class fields *) -module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - -(** Classes *) -module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> - ?params:(core_type * (variance * injectivity)) list -> - str -> 'a -> 'a class_infos - end - -(** Class signatures *) -module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - -(** Class structures *) -module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - -(** Row fields *) -module Rf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> bool -> core_type list -> row_field - val inherit_: ?loc:loc -> core_type -> row_field - end - -(** Object fields *) -module Of: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - object_field_desc -> object_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> core_type -> object_field - val inherit_: ?loc:loc -> core_type -> object_field - end diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml deleted file mode 100644 index 2398e772d1..0000000000 --- a/parsing/ast_iterator.ml +++ /dev/null @@ -1,697 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Nicolas Ojeda Bar, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* A generic Parsetree mapping class *) - -(* -[@@@ocaml.warning "+9"] - (* Ensure that record patterns don't miss any field. *) -*) - - -open Parsetree -open Location - -type iterator = { - attribute: iterator -> attribute -> unit; - attributes: iterator -> attribute list -> unit; - binding_op: iterator -> binding_op -> unit; - case: iterator -> case -> unit; - cases: iterator -> case list -> unit; - class_declaration: iterator -> class_declaration -> unit; - class_description: iterator -> class_description -> unit; - class_expr: iterator -> class_expr -> unit; - class_field: iterator -> class_field -> unit; - class_signature: iterator -> class_signature -> unit; - class_structure: iterator -> class_structure -> unit; - class_type: iterator -> class_type -> unit; - class_type_declaration: iterator -> class_type_declaration -> unit; - class_type_field: iterator -> class_type_field -> unit; - constructor_declaration: iterator -> constructor_declaration -> unit; - expr: iterator -> expression -> unit; - extension: iterator -> extension -> unit; - extension_constructor: iterator -> extension_constructor -> unit; - include_declaration: iterator -> include_declaration -> unit; - include_description: iterator -> include_description -> unit; - label_declaration: iterator -> label_declaration -> unit; - location: iterator -> Location.t -> unit; - module_binding: iterator -> module_binding -> unit; - module_declaration: iterator -> module_declaration -> unit; - module_substitution: iterator -> module_substitution -> unit; - module_expr: iterator -> module_expr -> unit; - module_type: iterator -> module_type -> unit; - module_type_declaration: iterator -> module_type_declaration -> unit; - open_declaration: iterator -> open_declaration -> unit; - open_description: iterator -> open_description -> unit; - pat: iterator -> pattern -> unit; - payload: iterator -> payload -> unit; - signature: iterator -> signature -> unit; - signature_item: iterator -> signature_item -> unit; - structure: iterator -> structure -> unit; - structure_item: iterator -> structure_item -> unit; - typ: iterator -> core_type -> unit; - row_field: iterator -> row_field -> unit; - object_field: iterator -> object_field -> unit; - type_declaration: iterator -> type_declaration -> unit; - type_extension: iterator -> type_extension -> unit; - type_exception: iterator -> type_exception -> unit; - type_kind: iterator -> type_kind -> unit; - value_binding: iterator -> value_binding -> unit; - value_description: iterator -> value_description -> unit; - with_constraint: iterator -> with_constraint -> unit; -} -(** A [iterator] record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the iterator to be applied to children in the syntax - tree. *) - -let iter_fst f (x, _) = f x -let iter_snd f (_, y) = f y -let iter_tuple f1 f2 (x, y) = f1 x; f2 y -let iter_tuple3 f1 f2 f3 (x, y, z) = f1 x; f2 y; f3 z -let iter_opt f = function None -> () | Some x -> f x - -let iter_loc sub {loc; txt = _} = sub.location sub loc - -module T = struct - (* Type expressions for the core language *) - - let row_field sub { - prf_desc; - prf_loc; - prf_attributes; - } = - sub.location sub prf_loc; - sub.attributes sub prf_attributes; - match prf_desc with - | Rtag (_, _, tl) -> List.iter (sub.typ sub) tl - | Rinherit t -> sub.typ sub t - - let object_field sub { - pof_desc; - pof_loc; - pof_attributes; - } = - sub.location sub pof_loc; - sub.attributes sub pof_attributes; - match pof_desc with - | Otag (_, t) -> sub.typ sub t - | Oinherit t -> sub.typ sub t - - let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Ptyp_any - | Ptyp_var _ -> () - | Ptyp_arrow (_lab, t1, t2) -> - sub.typ sub t1; sub.typ sub t2 - | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl - | Ptyp_constr (lid, tl) -> - iter_loc sub lid; List.iter (sub.typ sub) tl - | Ptyp_object (ol, _o) -> - List.iter (object_field sub) ol - | Ptyp_class (lid, tl) -> - iter_loc sub lid; List.iter (sub.typ sub) tl - | Ptyp_alias (t, _) -> sub.typ sub t - | Ptyp_variant (rl, _b, _ll) -> - List.iter (row_field sub) rl - | Ptyp_poly (_, t) -> sub.typ sub t - | Ptyp_package (lid, l) -> - iter_loc sub lid; - List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l - | Ptyp_extension x -> sub.extension sub x - - let iter_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private = _; - ptype_manifest; - ptype_attributes; - ptype_loc} = - iter_loc sub ptype_name; - List.iter (iter_fst (sub.typ sub)) ptype_params; - List.iter - (iter_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs; - sub.type_kind sub ptype_kind; - iter_opt (sub.typ sub) ptype_manifest; - sub.location sub ptype_loc; - sub.attributes sub ptype_attributes - - let iter_type_kind sub = function - | Ptype_abstract -> () - | Ptype_variant l -> - List.iter (sub.constructor_declaration sub) l - | Ptype_record l -> List.iter (sub.label_declaration sub) l - | Ptype_open -> () - - let iter_constructor_arguments sub = function - | Pcstr_tuple l -> List.iter (sub.typ sub) l - | Pcstr_record l -> - List.iter (sub.label_declaration sub) l - - let iter_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private = _; - ptyext_loc; - ptyext_attributes} = - iter_loc sub ptyext_path; - List.iter (sub.extension_constructor sub) ptyext_constructors; - List.iter (iter_fst (sub.typ sub)) ptyext_params; - sub.location sub ptyext_loc; - sub.attributes sub ptyext_attributes - - let iter_type_exception sub - {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = - sub.extension_constructor sub ptyexn_constructor; - sub.location sub ptyexn_loc; - sub.attributes sub ptyexn_attributes - - let iter_extension_constructor_kind sub = function - Pext_decl(vars, ctl, cto) -> - List.iter (iter_loc sub) vars; - iter_constructor_arguments sub ctl; - iter_opt (sub.typ sub) cto - | Pext_rebind li -> - iter_loc sub li - - let iter_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - iter_loc sub pext_name; - iter_extension_constructor_kind sub pext_kind; - sub.location sub pext_loc; - sub.attributes sub pext_attributes - -end - -module CT = struct - (* Type expressions for the class language *) - - let iter sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pcty_constr (lid, tys) -> - iter_loc sub lid; List.iter (sub.typ sub) tys - | Pcty_signature x -> sub.class_signature sub x - | Pcty_arrow (_lab, t, ct) -> - sub.typ sub t; sub.class_type sub ct - | Pcty_extension x -> sub.extension sub x - | Pcty_open (o, e) -> - sub.open_description sub o; sub.class_type sub e - - let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pctf_inherit ct -> sub.class_type sub ct - | Pctf_val (_s, _m, _v, t) -> sub.typ sub t - | Pctf_method (_s, _p, _v, t) -> sub.typ sub t - | Pctf_constraint (t1, t2) -> - sub.typ sub t1; sub.typ sub t2 - | Pctf_attribute x -> sub.attribute sub x - | Pctf_extension x -> sub.extension sub x - - let iter_signature sub {pcsig_self; pcsig_fields} = - sub.typ sub pcsig_self; - List.iter (sub.class_type_field sub) pcsig_fields -end - -let iter_functor_param sub = function - | Unit -> () - | Named (name, mty) -> - iter_loc sub name; - sub.module_type sub mty - -module MT = struct - (* Type expressions for the module language *) - - let iter sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pmty_ident s -> iter_loc sub s - | Pmty_alias s -> iter_loc sub s - | Pmty_signature sg -> sub.signature sub sg - | Pmty_functor (param, mt2) -> - iter_functor_param sub param; - sub.module_type sub mt2 - | Pmty_with (mt, l) -> - sub.module_type sub mt; - List.iter (sub.with_constraint sub) l - | Pmty_typeof me -> sub.module_expr sub me - | Pmty_extension x -> sub.extension sub x - - let iter_with_constraint sub = function - | Pwith_type (lid, d) -> - iter_loc sub lid; sub.type_declaration sub d - | Pwith_module (lid, lid2) -> - iter_loc sub lid; iter_loc sub lid2 - | Pwith_modtype (lid, mty) -> - iter_loc sub lid; sub.module_type sub mty - | Pwith_typesubst (lid, d) -> - iter_loc sub lid; sub.type_declaration sub d - | Pwith_modsubst (s, lid) -> - iter_loc sub s; iter_loc sub lid - | Pwith_modtypesubst (lid, mty) -> - iter_loc sub lid; sub.module_type sub mty - - let iter_signature_item sub {psig_desc = desc; psig_loc = loc} = - sub.location sub loc; - match desc with - | Psig_value vd -> sub.value_description sub vd - | Psig_type (_, l) - | Psig_typesubst l -> - List.iter (sub.type_declaration sub) l - | Psig_typext te -> sub.type_extension sub te - | Psig_exception ed -> sub.type_exception sub ed - | Psig_module x -> sub.module_declaration sub x - | Psig_modsubst x -> sub.module_substitution sub x - | Psig_recmodule l -> - List.iter (sub.module_declaration sub) l - | Psig_modtype x | Psig_modtypesubst x -> sub.module_type_declaration sub x - | Psig_open x -> sub.open_description sub x - | Psig_include x -> sub.include_description sub x - | Psig_class l -> List.iter (sub.class_description sub) l - | Psig_class_type l -> - List.iter (sub.class_type_declaration sub) l - | Psig_extension (x, attrs) -> - sub.attributes sub attrs; - sub.extension sub x - | Psig_attribute x -> sub.attribute sub x -end - - -module M = struct - (* Value expressions for the module language *) - - let iter sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pmod_ident x -> iter_loc sub x - | Pmod_structure str -> sub.structure sub str - | Pmod_functor (param, body) -> - iter_functor_param sub param; - sub.module_expr sub body - | Pmod_apply (m1, m2) -> - sub.module_expr sub m1; - sub.module_expr sub m2 - | Pmod_apply_unit m1 -> - sub.module_expr sub m1 - | Pmod_constraint (m, mty) -> - sub.module_expr sub m; sub.module_type sub mty - | Pmod_unpack e -> sub.expr sub e - | Pmod_extension x -> sub.extension sub x - - let iter_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - sub.location sub loc; - match desc with - | Pstr_eval (x, attrs) -> - sub.attributes sub attrs; sub.expr sub x - | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs - | Pstr_primitive vd -> sub.value_description sub vd - | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l - | Pstr_typext te -> sub.type_extension sub te - | Pstr_exception ed -> sub.type_exception sub ed - | Pstr_module x -> sub.module_binding sub x - | Pstr_recmodule l -> List.iter (sub.module_binding sub) l - | Pstr_modtype x -> sub.module_type_declaration sub x - | Pstr_open x -> sub.open_declaration sub x - | Pstr_class l -> List.iter (sub.class_declaration sub) l - | Pstr_class_type l -> - List.iter (sub.class_type_declaration sub) l - | Pstr_include x -> sub.include_declaration sub x - | Pstr_extension (x, attrs) -> - sub.attributes sub attrs; sub.extension sub x - | Pstr_attribute x -> sub.attribute sub x -end - -module E = struct - (* Value expressions for the core language *) - - let iter sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pexp_ident x -> iter_loc sub x - | Pexp_constant _ -> () - | Pexp_let (_r, vbs, e) -> - List.iter (sub.value_binding sub) vbs; - sub.expr sub e - | Pexp_fun (_lab, def, p, e) -> - iter_opt (sub.expr sub) def; - sub.pat sub p; - sub.expr sub e - | Pexp_function pel -> sub.cases sub pel - | Pexp_apply (e, l) -> - sub.expr sub e; List.iter (iter_snd (sub.expr sub)) l - | Pexp_match (e, pel) -> - sub.expr sub e; sub.cases sub pel - | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel - | Pexp_tuple el -> List.iter (sub.expr sub) el - | Pexp_construct (lid, arg) -> - iter_loc sub lid; iter_opt (sub.expr sub) arg - | Pexp_variant (_lab, eo) -> - iter_opt (sub.expr sub) eo - | Pexp_record (l, eo) -> - List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l; - iter_opt (sub.expr sub) eo - | Pexp_field (e, lid) -> - sub.expr sub e; iter_loc sub lid - | Pexp_setfield (e1, lid, e2) -> - sub.expr sub e1; iter_loc sub lid; - sub.expr sub e2 - | Pexp_array el -> List.iter (sub.expr sub) el - | Pexp_ifthenelse (e1, e2, e3) -> - sub.expr sub e1; sub.expr sub e2; - iter_opt (sub.expr sub) e3 - | Pexp_sequence (e1, e2) -> - sub.expr sub e1; sub.expr sub e2 - | Pexp_while (e1, e2) -> - sub.expr sub e1; sub.expr sub e2 - | Pexp_for (p, e1, e2, _d, e3) -> - sub.pat sub p; sub.expr sub e1; sub.expr sub e2; - sub.expr sub e3 - | Pexp_coerce (e, t1, t2) -> - sub.expr sub e; iter_opt (sub.typ sub) t1; - sub.typ sub t2 - | Pexp_constraint (e, t) -> - sub.expr sub e; sub.typ sub t - | Pexp_send (e, _s) -> sub.expr sub e - | Pexp_new lid -> iter_loc sub lid - | Pexp_setinstvar (s, e) -> - iter_loc sub s; sub.expr sub e - | Pexp_override sel -> - List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel - | Pexp_letmodule (s, me, e) -> - iter_loc sub s; sub.module_expr sub me; - sub.expr sub e - | Pexp_letexception (cd, e) -> - sub.extension_constructor sub cd; - sub.expr sub e - | Pexp_assert e -> sub.expr sub e - | Pexp_lazy e -> sub.expr sub e - | Pexp_poly (e, t) -> - sub.expr sub e; iter_opt (sub.typ sub) t - | Pexp_object cls -> sub.class_structure sub cls - | Pexp_newtype (_s, e) -> sub.expr sub e - | Pexp_pack me -> sub.module_expr sub me - | Pexp_open (o, e) -> - sub.open_declaration sub o; sub.expr sub e - | Pexp_letop {let_; ands; body} -> - sub.binding_op sub let_; - List.iter (sub.binding_op sub) ands; - sub.expr sub body - | Pexp_extension x -> sub.extension sub x - | Pexp_unreachable -> () - - let iter_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = - iter_loc sub pbop_op; - sub.pat sub pbop_pat; - sub.expr sub pbop_exp; - sub.location sub pbop_loc - -end - -module P = struct - (* Patterns *) - - let iter sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Ppat_any -> () - | Ppat_var s -> iter_loc sub s - | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s - | Ppat_constant _ -> () - | Ppat_interval _ -> () - | Ppat_tuple pl -> List.iter (sub.pat sub) pl - | Ppat_construct (l, p) -> - iter_loc sub l; - iter_opt - (fun (vl,p) -> - List.iter (iter_loc sub) vl; - sub.pat sub p) - p - | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p - | Ppat_record (lpl, _cf) -> - List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl - | Ppat_array pl -> List.iter (sub.pat sub) pl - | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2 - | Ppat_constraint (p, t) -> - sub.pat sub p; sub.typ sub t - | Ppat_type s -> iter_loc sub s - | Ppat_lazy p -> sub.pat sub p - | Ppat_unpack s -> iter_loc sub s - | Ppat_exception p -> sub.pat sub p - | Ppat_extension x -> sub.extension sub x - | Ppat_open (lid, p) -> - iter_loc sub lid; sub.pat sub p - -end - -module CE = struct - (* Value expressions for the class language *) - - let iter sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pcl_constr (lid, tys) -> - iter_loc sub lid; List.iter (sub.typ sub) tys - | Pcl_structure s -> - sub.class_structure sub s - | Pcl_fun (_lab, e, p, ce) -> - iter_opt (sub.expr sub) e; - sub.pat sub p; - sub.class_expr sub ce - | Pcl_apply (ce, l) -> - sub.class_expr sub ce; - List.iter (iter_snd (sub.expr sub)) l - | Pcl_let (_r, vbs, ce) -> - List.iter (sub.value_binding sub) vbs; - sub.class_expr sub ce - | Pcl_constraint (ce, ct) -> - sub.class_expr sub ce; sub.class_type sub ct - | Pcl_extension x -> sub.extension sub x - | Pcl_open (o, e) -> - sub.open_description sub o; sub.class_expr sub e - - let iter_kind sub = function - | Cfk_concrete (_o, e) -> sub.expr sub e - | Cfk_virtual t -> sub.typ sub t - - let iter_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pcf_inherit (_o, ce, _s) -> sub.class_expr sub ce - | Pcf_val (s, _m, k) -> iter_loc sub s; iter_kind sub k - | Pcf_method (s, _p, k) -> - iter_loc sub s; iter_kind sub k - | Pcf_constraint (t1, t2) -> - sub.typ sub t1; sub.typ sub t2 - | Pcf_initializer e -> sub.expr sub e - | Pcf_attribute x -> sub.attribute sub x - | Pcf_extension x -> sub.extension sub x - - let iter_structure sub {pcstr_self; pcstr_fields} = - sub.pat sub pcstr_self; - List.iter (sub.class_field sub) pcstr_fields - - let class_infos sub f {pci_virt = _; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - List.iter (iter_fst (sub.typ sub)) pl; - iter_loc sub pci_name; - f pci_expr; - sub.location sub pci_loc; - sub.attributes sub pci_attributes -end - -(* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - -let default_iterator = - { - structure = (fun this l -> List.iter (this.structure_item this) l); - structure_item = M.iter_structure_item; - module_expr = M.iter; - signature = (fun this l -> List.iter (this.signature_item this) l); - signature_item = MT.iter_signature_item; - module_type = MT.iter; - with_constraint = MT.iter_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.iter; - class_field = CE.iter_field; - class_structure = CE.iter_structure; - class_type = CT.iter; - class_type_field = CT.iter_field; - class_signature = CT.iter_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.iter_type_declaration; - type_kind = T.iter_type_kind; - typ = T.iter; - row_field = T.row_field; - object_field = T.object_field; - type_extension = T.iter_type_extension; - type_exception = T.iter_type_exception; - extension_constructor = T.iter_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim = _; pval_loc; - pval_attributes} -> - iter_loc this pval_name; - this.typ this pval_type; - this.location this pval_loc; - this.attributes this pval_attributes; - ); - - pat = P.iter; - expr = E.iter; - binding_op = E.iter_binding_op; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - iter_loc this pmd_name; - this.module_type this pmd_type; - this.location this pmd_loc; - this.attributes this pmd_attributes; - ); - - module_substitution = - (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> - iter_loc this pms_name; - iter_loc this pms_manifest; - this.location this pms_loc; - this.attributes this pms_attributes; - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - iter_loc this pmtd_name; - iter_opt (this.module_type this) pmtd_type; - this.location this pmtd_loc; - this.attributes this pmtd_attributes; - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - iter_loc this pmb_name; this.module_expr this pmb_expr; - this.location this pmb_loc; - this.attributes this pmb_attributes; - ); - - open_declaration = - (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} -> - this.module_expr this popen_expr; - this.location this popen_loc; - this.attributes this popen_attributes - ); - - open_description = - (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} -> - iter_loc this popen_expr; - this.location this popen_loc; - this.attributes this popen_attributes - ); - - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - this.module_type this pincl_mod; - this.location this pincl_loc; - this.attributes this pincl_attributes - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - this.module_expr this pincl_mod; - this.location this pincl_loc; - this.attributes this pincl_attributes - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc; pvb_constraint} -> - this.pat this pvb_pat; - this.expr this pvb_expr; - Option.iter (function - | Parsetree.Pvc_constraint {locally_abstract_univars=vars; typ} -> - List.iter (iter_loc this) vars; - this.typ this typ - | Pvc_coercion { ground; coercion } -> - Option.iter (this.typ this) ground; - this.typ this coercion; - ) pvb_constraint; - this.location this pvb_loc; - this.attributes this pvb_attributes - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_vars; pcd_args; - pcd_res; pcd_loc; pcd_attributes} -> - iter_loc this pcd_name; - List.iter (iter_loc this) pcd_vars; - T.iter_constructor_arguments this pcd_args; - iter_opt (this.typ this) pcd_res; - this.location this pcd_loc; - this.attributes this pcd_attributes - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes}-> - iter_loc this pld_name; - this.typ this pld_type; - this.location this pld_loc; - this.attributes this pld_attributes - ); - - cases = (fun this l -> List.iter (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - this.pat this pc_lhs; - iter_opt (this.expr this) pc_guard; - this.expr this pc_rhs - ); - - location = (fun _this _l -> ()); - - extension = (fun this (s, e) -> iter_loc this s; this.payload this e); - attribute = (fun this a -> - iter_loc this a.attr_name; - this.payload this a.attr_payload; - this.location this a.attr_loc - ); - attributes = (fun this l -> List.iter (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> this.structure this x - | PSig x -> this.signature this x - | PTyp x -> this.typ this x - | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g - ); - } diff --git a/parsing/ast_iterator.mli b/parsing/ast_iterator.mli deleted file mode 100644 index 638ac5e8b6..0000000000 --- a/parsing/ast_iterator.mli +++ /dev/null @@ -1,84 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Nicolas Ojeda Bar, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** {!Ast_iterator.iterator} enables AST inspection using open recursion. A - typical mapper would be based on {!Ast_iterator.default_iterator}, a - trivial iterator, and will fall back on it for handling the syntax it does - not modify. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Parsetree - -(** {1 A generic Parsetree iterator} *) - -type iterator = { - attribute: iterator -> attribute -> unit; - attributes: iterator -> attribute list -> unit; - binding_op: iterator -> binding_op -> unit; - case: iterator -> case -> unit; - cases: iterator -> case list -> unit; - class_declaration: iterator -> class_declaration -> unit; - class_description: iterator -> class_description -> unit; - class_expr: iterator -> class_expr -> unit; - class_field: iterator -> class_field -> unit; - class_signature: iterator -> class_signature -> unit; - class_structure: iterator -> class_structure -> unit; - class_type: iterator -> class_type -> unit; - class_type_declaration: iterator -> class_type_declaration -> unit; - class_type_field: iterator -> class_type_field -> unit; - constructor_declaration: iterator -> constructor_declaration -> unit; - expr: iterator -> expression -> unit; - extension: iterator -> extension -> unit; - extension_constructor: iterator -> extension_constructor -> unit; - include_declaration: iterator -> include_declaration -> unit; - include_description: iterator -> include_description -> unit; - label_declaration: iterator -> label_declaration -> unit; - location: iterator -> Location.t -> unit; - module_binding: iterator -> module_binding -> unit; - module_declaration: iterator -> module_declaration -> unit; - module_substitution: iterator -> module_substitution -> unit; - module_expr: iterator -> module_expr -> unit; - module_type: iterator -> module_type -> unit; - module_type_declaration: iterator -> module_type_declaration -> unit; - open_declaration: iterator -> open_declaration -> unit; - open_description: iterator -> open_description -> unit; - pat: iterator -> pattern -> unit; - payload: iterator -> payload -> unit; - signature: iterator -> signature -> unit; - signature_item: iterator -> signature_item -> unit; - structure: iterator -> structure -> unit; - structure_item: iterator -> structure_item -> unit; - typ: iterator -> core_type -> unit; - row_field: iterator -> row_field -> unit; - object_field: iterator -> object_field -> unit; - type_declaration: iterator -> type_declaration -> unit; - type_extension: iterator -> type_extension -> unit; - type_exception: iterator -> type_exception -> unit; - type_kind: iterator -> type_kind -> unit; - value_binding: iterator -> value_binding -> unit; - value_description: iterator -> value_description -> unit; - with_constraint: iterator -> with_constraint -> unit; -} -(** A [iterator] record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the iterator to be applied to children in the syntax - tree. *) - -val default_iterator: iterator -(** A default iterator, which implements a "do not do anything" mapping. *) diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml deleted file mode 100644 index 5d97686bf2..0000000000 --- a/parsing/ast_mapper.ml +++ /dev/null @@ -1,1104 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* A generic Parsetree mapping class *) - -(* -[@@@ocaml.warning "+9"] - (* Ensure that record patterns don't miss any field. *) -*) - -open Parsetree -open Ast_helper -open Location - -module String = Misc.Stdlib.String - -type mapper = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; -} - -let map_fst f (x, y) = (f x, y) -let map_snd f (x, y) = (x, f y) -let map_tuple f1 f2 (x, y) = (f1 x, f2 y) -let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) -let map_opt f = function None -> None | Some x -> Some (f x) - -let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - -module C = struct - (* Constants *) - - let map sub c = match c with - | Pconst_integer _ - | Pconst_char _ - | Pconst_float _ - -> c - | Pconst_string (s, loc, quotation_delimiter) -> - let loc = sub.location sub loc in - Const.string ~loc ?quotation_delimiter s -end - -module T = struct - (* Type expressions for the core language *) - - let row_field sub { - prf_desc; - prf_loc; - prf_attributes; - } = - let loc = sub.location sub prf_loc in - let attrs = sub.attributes sub prf_attributes in - let desc = match prf_desc with - | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - in - Rf.mk ~loc ~attrs desc - - let object_field sub { - pof_desc; - pof_loc; - pof_attributes; - } = - let loc = sub.location sub pof_loc in - let attrs = sub.attributes sub pof_attributes in - let desc = match pof_desc with - | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t) - | Oinherit t -> Oinherit (sub.typ sub t) - in - Of.mk ~loc ~attrs desc - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs - (List.map (map_loc sub) sl) (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - let loc = sub.location sub ptype_loc in - let attrs = sub.attributes sub ptype_attributes in - Type.mk ~loc ~attrs (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_loc; - ptyext_attributes} = - let loc = sub.location sub ptyext_loc in - let attrs = sub.attributes sub ptyext_attributes in - Te.mk ~loc ~attrs - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - - let map_type_exception sub - {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = - let loc = sub.location sub ptyexn_loc in - let attrs = sub.attributes sub ptyexn_attributes in - Te.mk_exception ~loc ~attrs - (sub.extension_constructor sub ptyexn_constructor) - - let map_extension_constructor_kind sub = function - Pext_decl(vars, ctl, cto) -> - Pext_decl(List.map (map_loc sub) vars, - map_constructor_arguments sub ctl, - map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - let loc = sub.location sub pext_loc in - let attrs = sub.attributes sub pext_attributes in - Te.constructor ~loc ~attrs - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - -end - -module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (o, ct) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) -end - -let map_functor_param sub = function - | Unit -> Unit - | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt) - -module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (param, mt) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_type sub mt) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_modtype (lid, mty) -> - Pwith_modtype (map_loc sub lid, sub.module_type sub mty) - | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - | Pwith_modtypesubst (lid, mty) -> - Pwith_modtypesubst (map_loc sub lid, sub.module_type sub mty) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> - type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typesubst l -> - type_subst ~loc (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_modtypesubst x -> - modtype_subst ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) -end - - -module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (param, body) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_apply_unit m1 -> - apply_unit ~loc ~attrs (sub.module_expr sub m1) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - let attrs = sub.attributes sub attrs in - eval ~loc ~attrs (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_declaration sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) -end - -module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x) - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> - send ~loc ~attrs (sub.expr sub e) (map_loc sub s) - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (o, e) -> - open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e) - | Pexp_letop {let_; ands; body} -> - letop ~loc ~attrs (sub.binding_op sub let_) - (List.map (sub.binding_op sub) ands) (sub.expr sub body) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () - - let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = - let open Exp in - let op = map_loc sub pbop_op in - let pat = sub.pat sub pbop_pat in - let exp = sub.expr sub pbop_exp in - let loc = sub.location sub pbop_loc in - binding_op op pat exp loc - -end - -module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs (sub.constant sub c) - | Ppat_interval (c1, c2) -> - interval ~loc ~attrs (sub.constant sub c1) (sub.constant sub c2) - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) - (map_opt - (fun (vl, p) -> List.map (map_loc sub) vl, sub.pat sub p) - p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) -end - -module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (o, ce) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> - inherit_ ~loc ~attrs o (sub.class_expr sub ce) - (map_opt (map_loc sub) s) - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - let loc = sub.location sub pci_loc in - let attrs = sub.attributes sub pci_attributes in - Ci.mk ~loc ~attrs - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) -end - -(* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - -let default_mapper = - { - constant = C.map; - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - type_exception = T.map_type_exception; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - binding_op = E.map_binding_op; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_substitution = - (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> - Ms.mk - (map_loc this pms_name) - (map_loc this pms_manifest) - ~attrs:(this.attributes this pms_attributes) - ~loc:(this.location this pms_loc) - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_declaration = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (this.module_expr this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - open_description = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc} -> - let map_ct (ct:Parsetree.value_constraint) = match ct with - | Pvc_constraint {locally_abstract_univars=vars; typ} -> - Pvc_constraint - { locally_abstract_univars = List.map (map_loc this) vars; - typ = this.typ this typ - } - | Pvc_coercion { ground; coercion } -> - Pvc_coercion { - ground = Option.map (this.typ this) ground; - coercion = this.typ this coercion - } - in - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ?value_constraint:(Option.map map_ct pvb_constraint) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_vars; pcd_args; - pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~vars:(List.map (map_loc this) pcd_vars) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this a -> - { - attr_name = map_loc this a.attr_name; - attr_payload = this.payload this a.attr_payload; - attr_loc = this.location this a.attr_loc - } - ); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - -let extension_of_error {kind; main; sub} = - if kind <> Location.Report_error then - raise (Invalid_argument "extension_of_error: expected kind Report_error"); - let str_of_pp pp_msg = Format.asprintf "%t" pp_msg in - let extension_of_sub sub = - { loc = sub.loc; txt = "ocaml.error" }, - PStr ([Str.eval (Exp.constant - (Pconst_string (str_of_pp sub.txt, sub.loc, None)))]) - in - { loc = main.loc; txt = "ocaml.error" }, - PStr (Str.eval (Exp.constant - (Pconst_string (str_of_pp main.txt, main.loc, None))) :: - List.map (fun msg -> Str.extension (extension_of_sub msg)) sub) - -let attribute_of_warning loc s = - Attr.mk - {loc; txt = "ocaml.ppwarning" } - (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, loc, None)))])) - -let cookies = ref String.Map.empty - -let get_cookie k = - try Some (String.Map.find k !cookies) - with Not_found -> None - -let set_cookie k v = - cookies := String.Map.add k v !cookies - -let tool_name_ref = ref "_none_" - -let tool_name () = !tool_name_ref - - -module PpxContext = struct - open Longident - open Asttypes - open Ast_helper - - let lid name = { txt = Lident name; loc = Location.none } - - let make_string s = Exp.constant (Const.string s) - - let make_bool x = - if x - then Exp.construct (lid "true") None - else Exp.construct (lid "false") None - - let rec make_list f lst = - match lst with - | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) - | [] -> - Exp.construct (lid "[]") None - - let make_pair f1 f2 (x1, x2) = - Exp.tuple [f1 x1; f2 x2] - - let make_option f opt = - match opt with - | Some x -> Exp.construct (lid "Some") (Some (f x)) - | None -> Exp.construct (lid "None") None - - let get_cookies () = - lid "cookies", - make_list (make_pair make_string (fun x -> x)) - (String.Map.bindings !cookies) - - let mk fields = - { - attr_name = { txt = "ocaml.ppx.context"; loc = Location.none }; - attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)]; - attr_loc = Location.none - } - - let make ~tool_name () = - let fields = - [ - lid "tool_name", make_string tool_name; - lid "include_dirs", make_list make_string !Clflags.include_dirs; - lid "load_path", make_list make_string (Load_path.get_paths ()); - lid "open_modules", make_list make_string !Clflags.open_modules; - lid "for_package", make_option make_string !Clflags.for_package; - lid "debug", make_bool !Clflags.debug; - lid "use_threads", make_bool !Clflags.use_threads; - lid "use_vmthreads", make_bool false; - lid "recursive_types", make_bool !Clflags.recursive_types; - lid "principal", make_bool !Clflags.principal; - lid "transparent_modules", make_bool !Clflags.transparent_modules; - lid "unboxed_types", make_bool !Clflags.unboxed_types; - lid "unsafe_string", make_bool false; (* kept for compatibility *) - get_cookies () - ] - in - mk fields - - let get_fields = function - | PStr [{pstr_desc = Pstr_eval - ({ pexp_desc = Pexp_record (fields, None) }, [])}] -> - fields - | _ -> - raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" - - let restore fields = - let field name payload = - let rec get_string = function - | { pexp_desc = Pexp_constant (Pconst_string (str, _, None)) } -> str - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] string syntax" name - and get_bool pexp = - match pexp with - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, - None)} -> - true - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, - None)} -> - false - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] bool syntax" name - and get_list elem = function - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> - elem exp :: get_list elem rest - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> - [] - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] list syntax" name - and get_pair f1 f2 = function - | {pexp_desc = Pexp_tuple [e1; e2]} -> - (f1 e1, f2 e2) - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] pair syntax" name - and get_option elem = function - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> - Some (elem exp) - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> - None - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] option syntax" name - in - match name with - | "tool_name" -> - tool_name_ref := get_string payload - | "include_dirs" -> - Clflags.include_dirs := get_list get_string payload - | "load_path" -> - (* Duplicates Compmisc.auto_include, since we can't reference Compmisc - from this module. *) - let auto_include find_in_dir fn = - if !Clflags.no_std_include then - raise Not_found - else - let alert = Location.auto_include_alert in - Load_path.auto_include_otherlibs alert find_in_dir fn - in - Load_path.init ~auto_include (get_list get_string payload) - | "open_modules" -> - Clflags.open_modules := get_list get_string payload - | "for_package" -> - Clflags.for_package := get_option get_string payload - | "debug" -> - Clflags.debug := get_bool payload - | "use_threads" -> - Clflags.use_threads := get_bool payload - | "use_vmthreads" -> - if get_bool payload then - raise_errorf "Internal error: vmthreads not supported after 4.09.0" - | "recursive_types" -> - Clflags.recursive_types := get_bool payload - | "principal" -> - Clflags.principal := get_bool payload - | "transparent_modules" -> - Clflags.transparent_modules := get_bool payload - | "unboxed_types" -> - Clflags.unboxed_types := get_bool payload - | "cookies" -> - let l = get_list (get_pair get_string (fun x -> x)) payload in - cookies := - List.fold_left - (fun s (k, v) -> String.Map.add k v s) String.Map.empty - l - | _ -> - () - in - List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields - - let update_cookies fields = - let fields = - List.filter - (function ({txt=Lident "cookies"}, _) -> false | _ -> true) - fields - in - fields @ [get_cookies ()] -end - -let ppx_context = PpxContext.make - -let extension_of_exn exn = - match error_of_exn exn with - | Some (`Ok error) -> extension_of_error error - | Some `Already_displayed -> - { loc = Location.none; txt = "ocaml.error" }, PStr [] - | None -> raise exn - - -let apply_lazy ~source ~target mapper = - let implem ast = - let fields, ast = - match ast with - | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.structure mapper ast - with exn -> - [{pstr_desc = Pstr_extension (extension_of_exn exn, []); - pstr_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Str.attribute (PpxContext.mk fields) :: ast - in - let iface ast = - let fields, ast = - match ast with - | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x; - attr_loc = _})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.signature mapper ast - with exn -> - [{psig_desc = Psig_extension (extension_of_exn exn, []); - psig_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Sig.attribute (PpxContext.mk fields) :: ast - in - - let ic = open_in_bin source in - let magic = - really_input_string ic (String.length Config.ast_impl_magic_number) - in - - let rewrite transform = - Location.input_name := input_value ic; - let ast = input_value ic in - close_in ic; - let ast = transform ast in - let oc = open_out_bin target in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc - and fail () = - close_in ic; - failwith "Ast_mapper: OCaml version mismatch or malformed input"; - in - - if magic = Config.ast_impl_magic_number then - rewrite (implem : structure -> structure) - else if magic = Config.ast_intf_magic_number then - rewrite (iface : signature -> signature) - else fail () - -let drop_ppx_context_str ~restore = function - | {pstr_desc = Pstr_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - -let drop_ppx_context_sig ~restore = function - | {psig_desc = Psig_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - -let add_ppx_context_str ~tool_name ast = - Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast - -let add_ppx_context_sig ~tool_name ast = - Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast - - -let apply ~source ~target mapper = - apply_lazy ~source ~target (fun () -> mapper) - -let run_main mapper = - try - let a = Sys.argv in - let n = Array.length a in - if n > 2 then - let mapper () = - try mapper (Array.to_list (Array.sub a 1 (n - 3))) - with exn -> - (* PR#6463 *) - let f _ _ = raise exn in - {default_mapper with structure = f; signature = f} - in - apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper - else begin - Printf.eprintf "Usage: %s [extra_args] \n%!" - Sys.executable_name; - exit 2 - end - with exn -> - prerr_endline (Printexc.to_string exn); - exit 2 - -let register_function = ref (fun _name f -> run_main f) -let register name f = !register_function name f diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli deleted file mode 100644 index 69f6b017ab..0000000000 --- a/parsing/ast_mapper.mli +++ /dev/null @@ -1,208 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** The interface of a -ppx rewriter - - A -ppx rewriter is a program that accepts a serialized abstract syntax - tree and outputs another, possibly modified, abstract syntax tree. - This module encapsulates the interface between the compiler and - the -ppx rewriters, handling such details as the serialization format, - forwarding of command-line flags, and storing state. - - {!mapper} enables AST rewriting using open recursion. - A typical mapper would be based on {!default_mapper}, a deep - identity mapper, and will fall back on it for handling the syntax it - does not modify. For example: - - {[ -open Asttypes -open Parsetree -open Ast_mapper - -let test_mapper argv = - { default_mapper with - expr = fun mapper expr -> - match expr with - | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> - Ast_helper.Exp.constant (Const_int 42) - | other -> default_mapper.expr mapper other; } - -let () = - register "ppx_test" test_mapper]} - - This -ppx rewriter, which replaces [[%test]] in expressions with - the constant [42], can be compiled using - [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - - *) - -open Parsetree - -(** {1 A generic Parsetree mapper} *) - -type mapper = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; -} -(** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - -val default_mapper: mapper -(** A default mapper, which implements a "deep identity" mapping. *) - -(** {1 Apply mappers to compilation units} *) - -val tool_name: unit -> string -(** Can be used within a ppx preprocessor to know which tool is - calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], - ["ocaml"], ... Some global variables that reflect command-line - options are automatically synchronized between the calling tool - and the ppx preprocessor: {!Clflags.include_dirs}, - {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package}, - {!Clflags.debug}. *) - - -val apply: source:string -> target:string -> mapper -> unit -(** Apply a mapper (parametrized by the unit name) to a dumped - parsetree found in the [source] file and put the result in the - [target] file. The [structure] or [signature] field of the mapper - is applied to the implementation or interface. *) - -val run_main: (string list -> mapper) -> unit -(** Entry point to call to implement a standalone -ppx rewriter from a - mapper, parametrized by the command line arguments. The current - unit name can be obtained from {!Location.input_name}. This - function implements proper error reporting for uncaught - exceptions. *) - -(** {1 Registration API} *) - -val register_function: (string -> (string list -> mapper) -> unit) ref - -val register: string -> (string list -> mapper) -> unit -(** Apply the [register_function]. The default behavior is to run the - mapper immediately, taking arguments from the process command - line. This is to support a scenario where a mapper is linked as a - stand-alone executable. - - It is possible to overwrite the [register_function] to define - "-ppx drivers", which combine several mappers in a single process. - Typically, a driver starts by defining [register_function] to a - custom implementation, then lets ppx rewriters (linked statically - or dynamically) register themselves, and then run all or some of - them. It is also possible to have -ppx drivers apply rewriters to - only specific parts of an AST. - - The first argument to [register] is a symbolic name to be used by - the ppx driver. *) - - -(** {1 Convenience functions to write mappers} *) - -val map_opt: ('a -> 'b) -> 'a option -> 'b option - -val extension_of_error: Location.error -> extension -(** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) - -val attribute_of_warning: Location.t -> string -> attribute -(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) - -(** {1 Helper functions to call external mappers} *) - -val add_ppx_context_str: - tool_name:string -> Parsetree.structure -> Parsetree.structure -(** Extract information from the current environment and encode it - into an attribute which is prepended to the list of structure - items in order to pass the information to an external - processor. *) - -val add_ppx_context_sig: - tool_name:string -> Parsetree.signature -> Parsetree.signature -(** Same as [add_ppx_context_str], but for signatures. *) - -val drop_ppx_context_str: - restore:bool -> Parsetree.structure -> Parsetree.structure -(** Drop the ocaml.ppx.context attribute from a structure. If - [restore] is true, also restore the associated data in the current - process. *) - -val drop_ppx_context_sig: - restore:bool -> Parsetree.signature -> Parsetree.signature -(** Same as [drop_ppx_context_str], but for signatures. *) - -(** {1 Cookies} *) - -(** Cookies are used to pass information from a ppx processor to - a further invocation of itself, when called from the OCaml - toplevel (or other tools that support cookies). *) - -val set_cookie: string -> Parsetree.expression -> unit -val get_cookie: string -> Parsetree.expression option diff --git a/parsing/attr_helper.ml b/parsing/attr_helper.ml deleted file mode 100644 index 0a616cd746..0000000000 --- a/parsing/attr_helper.ml +++ /dev/null @@ -1,54 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jeremie Dimino, Jane Street Europe *) -(* *) -(* Copyright 2015 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Asttypes -open Parsetree - -type error = - | Multiple_attributes of string - | No_payload_expected of string - -exception Error of Location.t * error - -let get_no_payload_attribute alt_names attrs = - match List.filter (fun a -> List.mem a.attr_name.txt alt_names) attrs with - | [] -> None - | [ {attr_name = name; attr_payload = PStr []; attr_loc = _} ] -> Some name - | [ {attr_name = name; _} ] -> - raise (Error (name.loc, No_payload_expected name.txt)) - | _ :: {attr_name = name; _} :: _ -> - raise (Error (name.loc, Multiple_attributes name.txt)) - -let has_no_payload_attribute alt_names attrs = - match get_no_payload_attribute alt_names attrs with - | None -> false - | Some _ -> true - -open Format - -let report_error ppf = function - | Multiple_attributes name -> - fprintf ppf "Too many `%s' attributes" name - | No_payload_expected name -> - fprintf ppf "Attribute `%s' does not accept a payload" name - -let () = - Location.register_error_of_exn - (function - | Error (loc, err) -> - Some (Location.error_of_printer ~loc report_error err) - | _ -> - None - ) diff --git a/parsing/attr_helper.mli b/parsing/attr_helper.mli deleted file mode 100644 index a3ddc0c9cb..0000000000 --- a/parsing/attr_helper.mli +++ /dev/null @@ -1,41 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jeremie Dimino, Jane Street Europe *) -(* *) -(* Copyright 2015 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Helpers for attributes - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Asttypes -open Parsetree - -type error = - | Multiple_attributes of string - | No_payload_expected of string - -(** The [string list] argument of the following functions is a list of - alternative names for the attribute we are looking for. For instance: - - {[ - ["foo"; "ocaml.foo"] - ]} *) -val get_no_payload_attribute : string list -> attributes -> string loc option -val has_no_payload_attribute : string list -> attributes -> bool - -exception Error of Location.t * error - -val report_error: Format.formatter -> error -> unit diff --git a/parsing/depend.ml b/parsing/depend.ml deleted file mode 100644 index b743516d38..0000000000 --- a/parsing/depend.ml +++ /dev/null @@ -1,608 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Asttypes -open Location -open Longident -open Parsetree -module String = Misc.Stdlib.String - -let pp_deps = ref [] - -(* Module resolution map *) -(* Node (set of imports for this path, map for submodules) *) -type map_tree = Node of String.Set.t * bound_map -and bound_map = map_tree String.Map.t -let bound = Node (String.Set.empty, String.Map.empty) - -(*let get_free (Node (s, _m)) = s*) -let get_map (Node (_s, m)) = m -let make_leaf s = Node (String.Set.singleton s, String.Map.empty) -let make_node m = Node (String.Set.empty, m) -let rec weaken_map s (Node(s0,m0)) = - Node (String.Set.union s s0, String.Map.map (weaken_map s) m0) -let rec collect_free (Node (s, m)) = - String.Map.fold (fun _ n -> String.Set.union (collect_free n)) m s - -(* Returns the imports required to access the structure at path p *) -(* Only raises Not_found if the head of p is not in the toplevel map *) -let rec lookup_free p m = - match p with - [] -> raise Not_found - | s::p -> - let Node (f, m') = String.Map.find s m in - try lookup_free p m' with Not_found -> f - -(* Returns the node corresponding to the structure at path p *) -let rec lookup_map lid m = - match lid with - Lident s -> String.Map.find s m - | Ldot (l, s) -> String.Map.find s (get_map (lookup_map l m)) - | Lapply _ -> raise Not_found - -(* Collect free module identifiers in the a.s.t. *) - -let free_structure_names = ref String.Set.empty - -let add_names s = - free_structure_names := String.Set.union s !free_structure_names - -let rec add_path bv ?(p=[]) = function - | Lident s -> - let free = - try lookup_free (s::p) bv with Not_found -> String.Set.singleton s - in - (*String.Set.iter (fun s -> Printf.eprintf "%s " s) free; - prerr_endline "";*) - add_names free - | Ldot(l, s) -> add_path bv ~p:(s::p) l - | Lapply(l1, l2) -> add_path bv l1; add_path bv l2 - -let open_module bv lid = - match lookup_map lid bv with - | Node (s, m) -> - add_names s; - String.Map.fold String.Map.add m bv - | exception Not_found -> - add_path bv lid; bv - -let add_parent bv lid = - match lid.txt with - Ldot(l, _s) -> add_path bv l - | _ -> () - -let add = add_parent - -let add_module_path bv lid = add_path bv lid.txt - -let handle_extension ext = - match (fst ext).txt with - | "error" | "ocaml.error" -> - raise (Location.Error - (Builtin_attributes.error_of_extension ext)) - | _ -> - () - -let rec add_type bv ty = - match ty.ptyp_desc with - Ptyp_any -> () - | Ptyp_var _ -> () - | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2 - | Ptyp_tuple tl -> List.iter (add_type bv) tl - | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl - | Ptyp_object (fl, _) -> - List.iter - (fun {pof_desc; _} -> match pof_desc with - | Otag (_, t) -> add_type bv t - | Oinherit t -> add_type bv t) fl - | Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl - | Ptyp_alias(t, _) -> add_type bv t - | Ptyp_variant(fl, _, _) -> - List.iter - (fun {prf_desc; _} -> match prf_desc with - | Rtag(_, _, stl) -> List.iter (add_type bv) stl - | Rinherit sty -> add_type bv sty) - fl - | Ptyp_poly(_, t) -> add_type bv t - | Ptyp_package pt -> add_package_type bv pt - | Ptyp_extension e -> handle_extension e - -and add_package_type bv (lid, l) = - add bv lid; - List.iter (add_type bv) (List.map (fun (_, e) -> e) l) - -let add_opt add_fn bv = function - None -> () - | Some x -> add_fn bv x - -let add_constructor_arguments bv = function - | Pcstr_tuple l -> List.iter (add_type bv) l - | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l - -let add_constructor_decl bv pcd = - add_constructor_arguments bv pcd.pcd_args; - Option.iter (add_type bv) pcd.pcd_res - -let add_type_declaration bv td = - List.iter - (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2) - td.ptype_cstrs; - add_opt add_type bv td.ptype_manifest; - let add_tkind = function - Ptype_abstract -> () - | Ptype_variant cstrs -> - List.iter (add_constructor_decl bv) cstrs - | Ptype_record lbls -> - List.iter (fun pld -> add_type bv pld.pld_type) lbls - | Ptype_open -> () in - add_tkind td.ptype_kind - -let add_extension_constructor bv ext = - match ext.pext_kind with - Pext_decl(_, args, rty) -> - add_constructor_arguments bv args; - Option.iter (add_type bv) rty - | Pext_rebind lid -> add bv lid - -let add_type_extension bv te = - add bv te.ptyext_path; - List.iter (add_extension_constructor bv) te.ptyext_constructors - -let add_type_exception bv te = - add_extension_constructor bv te.ptyexn_constructor - -let pattern_bv = ref String.Map.empty - -let rec add_pattern bv pat = - match pat.ppat_desc with - Ppat_any -> () - | Ppat_var _ -> () - | Ppat_alias(p, _) -> add_pattern bv p - | Ppat_interval _ - | Ppat_constant _ -> () - | Ppat_tuple pl -> List.iter (add_pattern bv) pl - | Ppat_construct(c, opt) -> - add bv c; - add_opt - (fun bv (_,p) -> add_pattern bv p) - bv opt - | Ppat_record(pl, _) -> - List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl - | Ppat_array pl -> List.iter (add_pattern bv) pl - | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2 - | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty - | Ppat_variant(_, op) -> add_opt add_pattern bv op - | Ppat_type li -> add bv li - | Ppat_lazy p -> add_pattern bv p - | Ppat_unpack id -> - Option.iter - (fun name -> pattern_bv := String.Map.add name bound !pattern_bv) id.txt - | Ppat_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p - | Ppat_exception p -> add_pattern bv p - | Ppat_extension e -> handle_extension e - -let add_pattern bv pat = - pattern_bv := bv; - add_pattern bv pat; - !pattern_bv - -let rec add_expr bv exp = - match exp.pexp_desc with - Pexp_ident l -> add bv l - | Pexp_constant _ -> () - | Pexp_let(rf, pel, e) -> - let bv = add_bindings rf bv pel in add_expr bv e - | Pexp_fun (_, opte, p, e) -> - add_opt add_expr bv opte; add_expr (add_pattern bv p) e - | Pexp_function pel -> - add_cases bv pel - | Pexp_apply(e, el) -> - add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el - | Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel - | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel - | Pexp_tuple el -> List.iter (add_expr bv) el - | Pexp_construct(c, opte) -> add bv c; add_opt add_expr bv opte - | Pexp_variant(_, opte) -> add_opt add_expr bv opte - | Pexp_record(lblel, opte) -> - List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel; - add_opt add_expr bv opte - | Pexp_field(e, fld) -> add_expr bv e; add bv fld - | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2 - | Pexp_array el -> List.iter (add_expr bv) el - | Pexp_ifthenelse(e1, e2, opte3) -> - add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3 - | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2 - | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2 - | Pexp_for( _, e1, e2, _, e3) -> - add_expr bv e1; add_expr bv e2; add_expr bv e3 - | Pexp_coerce(e1, oty2, ty3) -> - add_expr bv e1; - add_opt add_type bv oty2; - add_type bv ty3 - | Pexp_constraint(e1, ty2) -> - add_expr bv e1; - add_type bv ty2 - | Pexp_send(e, _m) -> add_expr bv e - | Pexp_new li -> add bv li - | Pexp_setinstvar(_v, e) -> add_expr bv e - | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel - | Pexp_letmodule(id, m, e) -> - let b = add_module_binding bv m in - let bv = - match id.txt with - | None -> bv - | Some id -> String.Map.add id b bv - in - add_expr bv e - | Pexp_letexception(_, e) -> add_expr bv e - | Pexp_assert (e) -> add_expr bv e - | Pexp_lazy (e) -> add_expr bv e - | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t - | Pexp_object { pcstr_self = pat; pcstr_fields = fieldl } -> - let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl - | Pexp_newtype (_, e) -> add_expr bv e - | Pexp_pack m -> add_module_expr bv m - | Pexp_open (o, e) -> - let bv = open_declaration bv o in - add_expr bv e - | Pexp_letop {let_; ands; body} -> - let bv' = add_binding_op bv bv let_ in - let bv' = List.fold_left (add_binding_op bv) bv' ands in - add_expr bv' body - | Pexp_extension (({ txt = ("ocaml.extension_constructor"| - "extension_constructor"); _ }, - PStr [item]) as e) -> - begin match item.pstr_desc with - | Pstr_eval ({ pexp_desc = Pexp_construct (c, None) }, _) -> add bv c - | _ -> handle_extension e - end - | Pexp_extension e -> handle_extension e - | Pexp_unreachable -> () - -and add_cases bv cases = - List.iter (add_case bv) cases - -and add_case bv {pc_lhs; pc_guard; pc_rhs} = - let bv = add_pattern bv pc_lhs in - add_opt add_expr bv pc_guard; - add_expr bv pc_rhs - -and add_bindings recf bv pel = - let bv' = List.fold_left (fun bv x -> add_pattern bv x.pvb_pat) bv pel in - let bv = if recf = Recursive then bv' else bv in - let add_constraint = function - | Pvc_constraint {locally_abstract_univars=_; typ} -> - add_type bv typ - | Pvc_coercion { ground; coercion } -> - Option.iter (add_type bv) ground; - add_type bv coercion - in - let add_one_binding { pvb_pat= _ ; pvb_loc= _ ; pvb_constraint; pvb_expr } = - add_expr bv pvb_expr; - Option.iter add_constraint pvb_constraint - in - List.iter add_one_binding pel; - bv' - -and add_binding_op bv bv' pbop = - add_expr bv pbop.pbop_exp; - add_pattern bv' pbop.pbop_pat - -and add_modtype bv mty = - match mty.pmty_desc with - Pmty_ident l -> add bv l - | Pmty_alias l -> add_module_path bv l - | Pmty_signature s -> add_signature bv s - | Pmty_functor(param, mty2) -> - let bv = - match param with - | Unit -> bv - | Named (id, mty1) -> - add_modtype bv mty1; - match id.txt with - | None -> bv - | Some name -> String.Map.add name bound bv - in - add_modtype bv mty2 - | Pmty_with(mty, cstrl) -> - add_modtype bv mty; - List.iter - (function - | Pwith_type (_, td) -> add_type_declaration bv td - | Pwith_module (_, lid) -> add_module_path bv lid - | Pwith_modtype (_, mty) -> add_modtype bv mty - | Pwith_typesubst (_, td) -> add_type_declaration bv td - | Pwith_modsubst (_, lid) -> add_module_path bv lid - | Pwith_modtypesubst (_, mty) -> add_modtype bv mty - ) - cstrl - | Pmty_typeof m -> add_module_expr bv m - | Pmty_extension e -> handle_extension e - -and add_module_alias bv l = - (* If we are in delayed dependencies mode, we delay the dependencies - induced by "Lident s" *) - (if !Clflags.transparent_modules then add_parent else add_module_path) bv l; - try - lookup_map l.txt bv - with Not_found -> - match l.txt with - Lident s -> make_leaf s - | _ -> add_module_path bv l; bound (* cannot delay *) - -and add_modtype_binding bv mty = - match mty.pmty_desc with - Pmty_alias l -> - add_module_alias bv l - | Pmty_signature s -> - make_node (add_signature_binding bv s) - | Pmty_typeof modl -> - add_module_binding bv modl - | _ -> - add_modtype bv mty; bound - -and add_signature bv sg = - ignore (add_signature_binding bv sg) - -and add_signature_binding bv sg = - snd (List.fold_left add_sig_item (bv, String.Map.empty) sg) - -and add_sig_item (bv, m) item = - match item.psig_desc with - Psig_value vd -> - add_type bv vd.pval_type; (bv, m) - | Psig_type (_, dcls) - | Psig_typesubst dcls-> - List.iter (add_type_declaration bv) dcls; (bv, m) - | Psig_typext te -> - add_type_extension bv te; (bv, m) - | Psig_exception te -> - add_type_exception bv te; (bv, m) - | Psig_module pmd -> - let m' = add_modtype_binding bv pmd.pmd_type in - let add map = - match pmd.pmd_name.txt with - | None -> map - | Some name -> String.Map.add name m' map - in - (add bv, add m) - | Psig_modsubst pms -> - let m' = add_module_alias bv pms.pms_manifest in - let add = String.Map.add pms.pms_name.txt m' in - (add bv, add m) - | Psig_recmodule decls -> - let add = - List.fold_right (fun pmd map -> - match pmd.pmd_name.txt with - | None -> map - | Some name -> String.Map.add name bound map - ) decls - in - let bv' = add bv and m' = add m in - List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls; - (bv', m') - | Psig_modtype x | Psig_modtypesubst x-> - begin match x.pmtd_type with - None -> () - | Some mty -> add_modtype bv mty - end; - (bv, m) - | Psig_open od -> - (open_description bv od, m) - | Psig_include incl -> - let Node (s, m') = add_modtype_binding bv incl.pincl_mod in - add_names s; - let add = String.Map.fold String.Map.add m' in - (add bv, add m) - | Psig_class cdl -> - List.iter (add_class_description bv) cdl; (bv, m) - | Psig_class_type cdtl -> - List.iter (add_class_type_declaration bv) cdtl; (bv, m) - | Psig_attribute _ -> (bv, m) - | Psig_extension (e, _) -> - handle_extension e; - (bv, m) - -and open_description bv od = - let Node(s, m) = add_module_alias bv od.popen_expr in - add_names s; - String.Map.fold String.Map.add m bv - -and open_declaration bv od = - let Node (s, m) = add_module_binding bv od.popen_expr in - add_names s; - String.Map.fold String.Map.add m bv - -and add_module_binding bv modl = - match modl.pmod_desc with - Pmod_ident l -> add_module_alias bv l - | Pmod_structure s -> - make_node (snd @@ add_structure_binding bv s) - | _ -> add_module_expr bv modl; bound - -and add_module_expr bv modl = - match modl.pmod_desc with - Pmod_ident l -> add_module_path bv l - | Pmod_structure s -> ignore (add_structure bv s) - | Pmod_functor(param, modl) -> - let bv = - match param with - | Unit -> bv - | Named (id, mty) -> - add_modtype bv mty; - match id.txt with - | None -> bv - | Some name -> String.Map.add name bound bv - in - add_module_expr bv modl - | Pmod_apply (mod1, mod2) -> - add_module_expr bv mod1; - add_module_expr bv mod2 - | Pmod_apply_unit mod1 -> - add_module_expr bv mod1 - | Pmod_constraint(modl, mty) -> - add_module_expr bv modl; add_modtype bv mty - | Pmod_unpack(e) -> - add_expr bv e - | Pmod_extension e -> - handle_extension e - -and add_class_type bv cty = - match cty.pcty_desc with - Pcty_constr(l, tyl) -> - add bv l; List.iter (add_type bv) tyl - | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } -> - add_type bv ty; - List.iter (add_class_type_field bv) fieldl - | Pcty_arrow(_, ty1, cty2) -> - add_type bv ty1; add_class_type bv cty2 - | Pcty_extension e -> handle_extension e - | Pcty_open (o, e) -> - let bv = open_description bv o in - add_class_type bv e - -and add_class_type_field bv pctf = - match pctf.pctf_desc with - Pctf_inherit cty -> add_class_type bv cty - | Pctf_val(_, _, _, ty) -> add_type bv ty - | Pctf_method(_, _, _, ty) -> add_type bv ty - | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 - | Pctf_attribute _ -> () - | Pctf_extension e -> handle_extension e - -and add_class_description bv infos = - add_class_type bv infos.pci_expr - -and add_class_type_declaration bv infos = add_class_description bv infos - -and add_structure bv item_list = - let (bv, m) = add_structure_binding bv item_list in - add_names (collect_free (make_node m)); - bv - -and add_structure_binding bv item_list = - List.fold_left add_struct_item (bv, String.Map.empty) item_list - -and add_struct_item (bv, m) item : _ String.Map.t * _ String.Map.t = - match item.pstr_desc with - Pstr_eval (e, _attrs) -> - add_expr bv e; (bv, m) - | Pstr_value(rf, pel) -> - let bv = add_bindings rf bv pel in (bv, m) - | Pstr_primitive vd -> - add_type bv vd.pval_type; (bv, m) - | Pstr_type (_, dcls) -> - List.iter (add_type_declaration bv) dcls; (bv, m) - | Pstr_typext te -> - add_type_extension bv te; - (bv, m) - | Pstr_exception te -> - add_type_exception bv te; - (bv, m) - | Pstr_module x -> - let b = add_module_binding bv x.pmb_expr in - let add map = - match x.pmb_name.txt with - | None -> map - | Some name -> String.Map.add name b map - in - (add bv, add m) - | Pstr_recmodule bindings -> - let add = - List.fold_right (fun x map -> - match x.pmb_name.txt with - | None -> map - | Some name -> String.Map.add name bound map - ) bindings - in - let bv' = add bv and m = add m in - List.iter - (fun x -> add_module_expr bv' x.pmb_expr) - bindings; - (bv', m) - | Pstr_modtype x -> - begin match x.pmtd_type with - None -> () - | Some mty -> add_modtype bv mty - end; - (bv, m) - | Pstr_open od -> - (open_declaration bv od, m) - | Pstr_class cdl -> - List.iter (add_class_declaration bv) cdl; (bv, m) - | Pstr_class_type cdtl -> - List.iter (add_class_type_declaration bv) cdtl; (bv, m) - | Pstr_include incl -> - let Node (s, m') as n = add_module_binding bv incl.pincl_mod in - if !Clflags.transparent_modules then - add_names s - else - (* If we are not in the delayed dependency mode, we need to - collect all delayed dependencies imported by the include statement *) - add_names (collect_free n); - let add = String.Map.fold String.Map.add m' in - (add bv, add m) - | Pstr_attribute _ -> (bv, m) - | Pstr_extension (e, _) -> - handle_extension e; - (bv, m) - -and add_use_file bv top_phrs = - ignore (List.fold_left add_top_phrase bv top_phrs) - -and add_implementation bv l = - ignore (add_structure_binding bv l) - -and add_implementation_binding bv l = - snd (add_structure_binding bv l) - -and add_top_phrase bv = function - | Ptop_def str -> add_structure bv str - | Ptop_dir _ -> bv - -and add_class_expr bv ce = - match ce.pcl_desc with - Pcl_constr(l, tyl) -> - add bv l; List.iter (add_type bv) tyl - | Pcl_structure { pcstr_self = pat; pcstr_fields = fieldl } -> - let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl - | Pcl_fun(_, opte, pat, ce) -> - add_opt add_expr bv opte; - let bv = add_pattern bv pat in add_class_expr bv ce - | Pcl_apply(ce, exprl) -> - add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl - | Pcl_let(rf, pel, ce) -> - let bv = add_bindings rf bv pel in add_class_expr bv ce - | Pcl_constraint(ce, ct) -> - add_class_expr bv ce; add_class_type bv ct - | Pcl_extension e -> handle_extension e - | Pcl_open (o, e) -> - let bv = open_description bv o in - add_class_expr bv e - -and add_class_field bv pcf = - match pcf.pcf_desc with - Pcf_inherit(_, ce, _) -> add_class_expr bv ce - | Pcf_val(_, _, Cfk_concrete (_, e)) - | Pcf_method(_, _, Cfk_concrete (_, e)) -> add_expr bv e - | Pcf_val(_, _, Cfk_virtual ty) - | Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty - | Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 - | Pcf_initializer e -> add_expr bv e - | Pcf_attribute _ -> () - | Pcf_extension e -> handle_extension e - -and add_class_declaration bv decl = - add_class_expr bv decl.pci_expr diff --git a/parsing/depend.mli b/parsing/depend.mli deleted file mode 100644 index 74c095f969..0000000000 --- a/parsing/depend.mli +++ /dev/null @@ -1,45 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Module dependencies. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -module String = Misc.Stdlib.String - -type map_tree = Node of String.Set.t * bound_map -and bound_map = map_tree String.Map.t -val make_leaf : string -> map_tree -val make_node : bound_map -> map_tree -val weaken_map : String.Set.t -> map_tree -> map_tree - -val free_structure_names : String.Set.t ref - -(** dependencies found by preprocessing tools *) -val pp_deps : string list ref - -val open_module : bound_map -> Longident.t -> bound_map - -val add_use_file : bound_map -> Parsetree.toplevel_phrase list -> unit - -val add_signature : bound_map -> Parsetree.signature -> unit - -val add_implementation : bound_map -> Parsetree.structure -> unit - -val add_implementation_binding : bound_map -> Parsetree.structure -> bound_map -val add_signature_binding : bound_map -> Parsetree.signature -> bound_map diff --git a/parsing/docstrings.ml b/parsing/docstrings.ml deleted file mode 100644 index a39f75d259..0000000000 --- a/parsing/docstrings.ml +++ /dev/null @@ -1,425 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Leo White *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Location - -(* Docstrings *) - -(* A docstring is "attached" if it has been inserted in the AST. This - is used for generating unexpected docstring warnings. *) -type ds_attached = - | Unattached (* Not yet attached anything.*) - | Info (* Attached to a field or constructor. *) - | Docs (* Attached to an item or as floating text. *) - -(* A docstring is "associated" with an item if there are no blank lines between - them. This is used for generating docstring ambiguity warnings. *) -type ds_associated = - | Zero (* Not associated with an item *) - | One (* Associated with one item *) - | Many (* Associated with multiple items (ambiguity) *) - -type docstring = - { ds_body: string; - ds_loc: Location.t; - mutable ds_attached: ds_attached; - mutable ds_associated: ds_associated; } - -(* List of docstrings *) - -let docstrings : docstring list ref = ref [] - -(* Warn for unused and ambiguous docstrings *) - -let warn_bad_docstrings () = - if Warnings.is_active (Warnings.Unexpected_docstring true) then begin - List.iter - (fun ds -> - match ds.ds_attached with - | Info -> () - | Unattached -> - prerr_warning ds.ds_loc (Warnings.Unexpected_docstring true) - | Docs -> - match ds.ds_associated with - | Zero | One -> () - | Many -> - prerr_warning ds.ds_loc (Warnings.Unexpected_docstring false)) - (List.rev !docstrings) -end - -(* Docstring constructors and destructors *) - -let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; - ds_attached = Unattached; - ds_associated = Zero; } - in - ds - -let register ds = - docstrings := ds :: !docstrings - -let docstring_body ds = ds.ds_body - -let docstring_loc ds = ds.ds_loc - -(* Docstrings attached to items *) - -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - -let empty_docs = { docs_pre = None; docs_post = None } - -let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - -let docs_attr ds = - let open Parsetree in - let body = ds.ds_body in - let loc = ds.ds_loc in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } - in - { attr_name = doc_loc; - attr_payload = PStr [item]; - attr_loc = loc } - -let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - -(* Docstrings attached to constructors or fields *) - -type info = docstring option - -let empty_info = None - -let info_attr = docs_attr - -let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - -(* Docstrings not attached to a specific item *) - -type text = docstring list - -let empty_text = [] -let empty_text_lazy = lazy [] - -let text_loc = {txt = "ocaml.text"; loc = Location.none} - -let text_attr ds = - let open Parsetree in - let body = ds.ds_body in - let loc = ds.ds_loc in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } - in - { attr_name = text_loc; - attr_payload = PStr [item]; - attr_loc = loc } - -let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - -(* Find the first non-info docstring in a list, attach it and return it *) -let get_docstring ~info dsl = - let rec loop = function - | [] -> None - | {ds_attached = Info; _} :: rest -> loop rest - | ds :: _ -> - ds.ds_attached <- if info then Info else Docs; - Some ds - in - loop dsl - -(* Find all the non-info docstrings in a list, attach them and return them *) -let get_docstrings dsl = - let rec loop acc = function - | [] -> List.rev acc - | {ds_attached = Info; _} :: rest -> loop acc rest - | ds :: rest -> - ds.ds_attached <- Docs; - loop (ds :: acc) rest - in - loop [] dsl - -(* "Associate" all the docstrings in a list *) -let associate_docstrings dsl = - List.iter - (fun ds -> - match ds.ds_associated with - | Zero -> ds.ds_associated <- One - | (One | Many) -> ds.ds_associated <- Many) - dsl - -(* Map from positions to pre docstrings *) - -let pre_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_pre_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_table pos dsl - -let get_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - -let mark_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl - with Not_found -> () - -(* Map from positions to post docstrings *) - -let post_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_post_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_table pos dsl - -let get_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - -let mark_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl - with Not_found -> () - -let get_info pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstring ~info:true dsl - with Not_found -> None - -(* Map from positions to floating docstrings *) - -let floating_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_floating_docstrings pos dsl = - if dsl <> [] then Hashtbl.add floating_table pos dsl - -let get_text pos = - try - let dsl = Hashtbl.find floating_table pos in - get_docstrings dsl - with Not_found -> [] - -let get_post_text pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstrings dsl - with Not_found -> [] - -(* Maps from positions to extra docstrings *) - -let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_pre_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_extra_table pos dsl - -let get_pre_extra_text pos = - try - let dsl = Hashtbl.find pre_extra_table pos in - get_docstrings dsl - with Not_found -> [] - -let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_post_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_extra_table pos dsl - -let get_post_extra_text pos = - try - let dsl = Hashtbl.find post_extra_table pos in - get_docstrings dsl - with Not_found -> [] - -(* Docstrings from parser actions *) -module WithParsing = struct -let symbol_docs () = - { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); - docs_post = get_post_docs (Parsing.symbol_end_pos ()); } - -let symbol_docs_lazy () = - let p1 = Parsing.symbol_start_pos () in - let p2 = Parsing.symbol_end_pos () in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); - docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } - -let rhs_docs_lazy pos1 pos2 = - let p1 = Parsing.rhs_start_pos pos1 in - let p2 = Parsing.rhs_end_pos pos2 in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let mark_symbol_docs () = - mark_pre_docs (Parsing.symbol_start_pos ()); - mark_post_docs (Parsing.symbol_end_pos ()) - -let mark_rhs_docs pos1 pos2 = - mark_pre_docs (Parsing.rhs_start_pos pos1); - mark_post_docs (Parsing.rhs_end_pos pos2) - -let symbol_info () = - get_info (Parsing.symbol_end_pos ()) - -let rhs_info pos = - get_info (Parsing.rhs_end_pos pos) - -let symbol_text () = - get_text (Parsing.symbol_start_pos ()) - -let symbol_text_lazy () = - let pos = Parsing.symbol_start_pos () in - lazy (get_text pos) - -let rhs_text pos = - get_text (Parsing.rhs_start_pos pos) - -let rhs_post_text pos = - get_post_text (Parsing.rhs_end_pos pos) - -let rhs_text_lazy pos = - let pos = Parsing.rhs_start_pos pos in - lazy (get_text pos) - -let symbol_pre_extra_text () = - get_pre_extra_text (Parsing.symbol_start_pos ()) - -let symbol_post_extra_text () = - get_post_extra_text (Parsing.symbol_end_pos ()) - -let rhs_pre_extra_text pos = - get_pre_extra_text (Parsing.rhs_start_pos pos) - -let rhs_post_extra_text pos = - get_post_extra_text (Parsing.rhs_end_pos pos) -end - -include WithParsing - -module WithMenhir = struct -let symbol_docs (startpos, endpos) = - { docs_pre = get_pre_docs startpos; - docs_post = get_post_docs endpos; } - -let symbol_docs_lazy (p1, p2) = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs pos1; - docs_post = get_post_docs pos2; } - -let rhs_docs_lazy p1 p2 = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let mark_symbol_docs (startpos, endpos) = - mark_pre_docs startpos; - mark_post_docs endpos; - () - -let mark_rhs_docs pos1 pos2 = - mark_pre_docs pos1; - mark_post_docs pos2; - () - -let symbol_info endpos = - get_info endpos - -let rhs_info endpos = - get_info endpos - -let symbol_text startpos = - get_text startpos - -let symbol_text_lazy startpos = - lazy (get_text startpos) - -let rhs_text pos = - get_text pos - -let rhs_post_text pos = - get_post_text pos - -let rhs_text_lazy pos = - lazy (get_text pos) - -let symbol_pre_extra_text startpos = - get_pre_extra_text startpos - -let symbol_post_extra_text endpos = - get_post_extra_text endpos - -let rhs_pre_extra_text pos = - get_pre_extra_text pos - -let rhs_post_extra_text pos = - get_post_extra_text pos -end - -(* (Re)Initialise all comment state *) - -let init () = - docstrings := []; - Hashtbl.reset pre_table; - Hashtbl.reset post_table; - Hashtbl.reset floating_table; - Hashtbl.reset pre_extra_table; - Hashtbl.reset post_extra_table diff --git a/parsing/docstrings.mli b/parsing/docstrings.mli deleted file mode 100644 index bf2508fdc4..0000000000 --- a/parsing/docstrings.mli +++ /dev/null @@ -1,223 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Leo White *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Documentation comments - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -(** (Re)Initialise all docstring state *) -val init : unit -> unit - -(** Emit warnings for unattached and ambiguous docstrings *) -val warn_bad_docstrings : unit -> unit - -(** {2 Docstrings} *) - -(** Documentation comments *) -type docstring - -(** Create a docstring *) -val docstring : string -> Location.t -> docstring - -(** Register a docstring *) -val register : docstring -> unit - -(** Get the text of a docstring *) -val docstring_body : docstring -> string - -(** Get the location of a docstring *) -val docstring_loc : docstring -> Location.t - -(** {2 Set functions} - - These functions are used by the lexer to associate docstrings to - the locations of tokens. *) - -(** Docstrings immediately preceding a token *) -val set_pre_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following a token *) -val set_post_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings not immediately adjacent to a token *) -val set_floating_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following the token which precedes this one *) -val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately preceding the token which follows this one *) -val set_post_extra_docstrings : Lexing.position -> docstring list -> unit - -(** {2 Items} - - The {!docs} type represents documentation attached to an item. *) - -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - -val empty_docs : docs - -val docs_attr : docstring -> Parsetree.attribute - -(** Convert item documentation to attributes and add them to an - attribute list *) -val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) -val symbol_docs : unit -> docs -val symbol_docs_lazy : unit -> docs Lazy.t - -(** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) -val rhs_docs : int -> int -> docs -val rhs_docs_lazy : int -> int -> docs Lazy.t - -(** Mark the item documentation for the current symbol (for ambiguity - warnings). *) -val mark_symbol_docs : unit -> unit - -(** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) -val mark_rhs_docs : int -> int -> unit - -(** {2 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - -type info = docstring option - -val empty_info : info - -val info_attr : docstring -> Parsetree.attribute - -(** Convert field info to attributes and add them to an - attribute list *) -val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the field info for the current symbol. *) -val symbol_info : unit -> info - -(** Fetch the field info following the symbol at a given position. *) -val rhs_info : int -> info - -(** {2 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - -type text = docstring list - -val empty_text : text -val empty_text_lazy : text Lazy.t - -val text_attr : docstring -> Parsetree.attribute - -(** Convert text to attributes and add them to an attribute list *) -val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the text preceding the current symbol. *) -val symbol_text : unit -> text -val symbol_text_lazy : unit -> text Lazy.t - -(** Fetch the text preceding the symbol at the given position. *) -val rhs_text : int -> text -val rhs_text_lazy : int -> text Lazy.t - -(** {2 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - -(** Fetch additional text preceding the current symbol *) -val symbol_pre_extra_text : unit -> text - -(** Fetch additional text following the current symbol *) -val symbol_post_extra_text : unit -> text - -(** Fetch additional text preceding the symbol at the given position *) -val rhs_pre_extra_text : int -> text - -(** Fetch additional text following the symbol at the given position *) -val rhs_post_extra_text : int -> text - -(** Fetch text following the symbol at the given position *) -val rhs_post_text : int -> text - -module WithMenhir: sig -(** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) -val symbol_docs : Lexing.position * Lexing.position -> docs -val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t - -(** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) -val rhs_docs : Lexing.position -> Lexing.position -> docs -val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t - -(** Mark the item documentation for the current symbol (for ambiguity - warnings). *) -val mark_symbol_docs : Lexing.position * Lexing.position -> unit - -(** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) -val mark_rhs_docs : Lexing.position -> Lexing.position -> unit - -(** Fetch the field info for the current symbol. *) -val symbol_info : Lexing.position -> info - -(** Fetch the field info following the symbol at a given position. *) -val rhs_info : Lexing.position -> info - -(** Fetch the text preceding the current symbol. *) -val symbol_text : Lexing.position -> text -val symbol_text_lazy : Lexing.position -> text Lazy.t - -(** Fetch the text preceding the symbol at the given position. *) -val rhs_text : Lexing.position -> text -val rhs_text_lazy : Lexing.position -> text Lazy.t - -(** {3 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - -(** Fetch additional text preceding the current symbol *) -val symbol_pre_extra_text : Lexing.position -> text - -(** Fetch additional text following the current symbol *) -val symbol_post_extra_text : Lexing.position -> text - -(** Fetch additional text preceding the symbol at the given position *) -val rhs_pre_extra_text : Lexing.position -> text - -(** Fetch additional text following the symbol at the given position *) -val rhs_post_extra_text : Lexing.position -> text - -(** Fetch text following the symbol at the given position *) -val rhs_post_text : Lexing.position -> text - -end diff --git a/parsing/lexer.mli b/parsing/lexer.mli deleted file mode 100644 index b5d3a96ac1..0000000000 --- a/parsing/lexer.mli +++ /dev/null @@ -1,64 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** The lexical analyzer - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -val init : unit -> unit -val token: Lexing.lexbuf -> Parser.token -val skip_hash_bang: Lexing.lexbuf -> unit - -type error = - | Illegal_character of char - | Illegal_escape of string * string option - | Reserved_sequence of string * string option - | Unterminated_comment of Location.t - | Unterminated_string - | Unterminated_string_in_comment of Location.t * Location.t - | Empty_character_literal - | Keyword_as_label of string - | Invalid_literal of string - | Invalid_directive of string * string option - -exception Error of error * Location.t - -val in_comment : unit -> bool -val in_string : unit -> bool - - -val print_warnings : bool ref -val handle_docstrings: bool ref -val comments : unit -> (string * Location.t) list -val token_with_comments : Lexing.lexbuf -> Parser.token - -(* - [set_preprocessor init preprocessor] registers [init] as the function -to call to initialize the preprocessor when the lexer is initialized, -and [preprocessor] a function that is called when a new token is needed -by the parser, as [preprocessor lexer lexbuf] where [lexer] is the -lexing function. - -When a preprocessor is configured by calling [set_preprocessor], the lexer -changes its behavior to accept backslash-newline as a token-separating blank. -*) - -val set_preprocessor : - (unit -> unit) -> - ((Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> Parser.token) -> - unit diff --git a/parsing/lexer.mll b/parsing/lexer.mll deleted file mode 100644 index 7429b603b0..0000000000 --- a/parsing/lexer.mll +++ /dev/null @@ -1,869 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* The lexer definition *) - -{ -open Lexing -open Misc -open Parser - -type error = - | Illegal_character of char - | Illegal_escape of string * string option - | Reserved_sequence of string * string option - | Unterminated_comment of Location.t - | Unterminated_string - | Unterminated_string_in_comment of Location.t * Location.t - | Empty_character_literal - | Keyword_as_label of string - | Invalid_literal of string - | Invalid_directive of string * string option - -exception Error of error * Location.t - -(* The table of keywords *) - -let keyword_table = - create_hashtable 149 [ - "and", AND; - "as", AS; - "assert", ASSERT; - "begin", BEGIN; - "class", CLASS; - "constraint", CONSTRAINT; - "do", DO; - "done", DONE; - "downto", DOWNTO; - "else", ELSE; - "end", END; - "exception", EXCEPTION; - "external", EXTERNAL; - "false", FALSE; - "for", FOR; - "fun", FUN; - "function", FUNCTION; - "functor", FUNCTOR; - "if", IF; - "in", IN; - "include", INCLUDE; - "inherit", INHERIT; - "initializer", INITIALIZER; - "lazy", LAZY; - "let", LET; - "match", MATCH; - "method", METHOD; - "module", MODULE; - "mutable", MUTABLE; - "new", NEW; - "nonrec", NONREC; - "object", OBJECT; - "of", OF; - "open", OPEN; - "or", OR; -(* "parser", PARSER; *) - "private", PRIVATE; - "rec", REC; - "sig", SIG; - "struct", STRUCT; - "then", THEN; - "to", TO; - "true", TRUE; - "try", TRY; - "type", TYPE; - "val", VAL; - "virtual", VIRTUAL; - "when", WHEN; - "while", WHILE; - "with", WITH; - - "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *) - "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *) - "mod", INFIXOP3("mod"); - "land", INFIXOP3("land"); - "lsl", INFIXOP4("lsl"); - "lsr", INFIXOP4("lsr"); - "asr", INFIXOP4("asr") -] - -(* To buffer string literals *) - -let string_buffer = Buffer.create 256 -let reset_string_buffer () = Buffer.reset string_buffer -let get_stored_string () = Buffer.contents string_buffer - -let store_string_char c = Buffer.add_char string_buffer c -let store_string_utf_8_uchar u = Buffer.add_utf_8_uchar string_buffer u -let store_string s = Buffer.add_string string_buffer s -let store_lexeme lexbuf = store_string (Lexing.lexeme lexbuf) - -(* To store the position of the beginning of a string and comment *) -let string_start_loc = ref Location.none -let comment_start_loc = ref [] -let in_comment () = !comment_start_loc <> [] -let is_in_string = ref false -let in_string () = !is_in_string -let print_warnings = ref true - -(* Escaped chars are interpreted in strings unless they are in comments. *) -let store_escaped_char lexbuf c = - if in_comment () then store_lexeme lexbuf else store_string_char c - -let store_escaped_uchar lexbuf u = - if in_comment () then store_lexeme lexbuf else store_string_utf_8_uchar u - -let compute_quoted_string_idloc {Location.loc_start = orig_loc } shift id = - let id_start_pos = orig_loc.Lexing.pos_cnum + shift in - let loc_start = - Lexing.{orig_loc with pos_cnum = id_start_pos } - in - let loc_end = - Lexing.{orig_loc with pos_cnum = id_start_pos + String.length id} - in - {Location. loc_start ; loc_end ; loc_ghost = false } - -let wrap_string_lexer f lexbuf = - let loc_start = lexbuf.lex_curr_p in - reset_string_buffer(); - is_in_string := true; - let string_start = lexbuf.lex_start_p in - string_start_loc := Location.curr lexbuf; - let loc_end = f lexbuf in - is_in_string := false; - lexbuf.lex_start_p <- string_start; - let loc = Location.{loc_ghost= false; loc_start; loc_end} in - get_stored_string (), loc - -let wrap_comment_lexer comment lexbuf = - let start_loc = Location.curr lexbuf in - comment_start_loc := [start_loc]; - reset_string_buffer (); - let end_loc = comment lexbuf in - let s = get_stored_string () in - reset_string_buffer (); - s, - { start_loc with Location.loc_end = end_loc.Location.loc_end } - -let error lexbuf e = raise (Error(e, Location.curr lexbuf)) -let error_loc loc e = raise (Error(e, loc)) - -(* to translate escape sequences *) - -let digit_value c = - match c with - | 'a' .. 'f' -> 10 + Char.code c - Char.code 'a' - | 'A' .. 'F' -> 10 + Char.code c - Char.code 'A' - | '0' .. '9' -> Char.code c - Char.code '0' - | _ -> assert false - -let num_value lexbuf ~base ~first ~last = - let c = ref 0 in - for i = first to last do - let v = digit_value (Lexing.lexeme_char lexbuf i) in - assert(v < base); - c := (base * !c) + v - done; - !c - -let char_for_backslash = function - | 'n' -> '\010' - | 'r' -> '\013' - | 'b' -> '\008' - | 't' -> '\009' - | c -> c - -let illegal_escape lexbuf reason = - let error = Illegal_escape (Lexing.lexeme lexbuf, Some reason) in - raise (Error (error, Location.curr lexbuf)) - -let char_for_decimal_code lexbuf i = - let c = num_value lexbuf ~base:10 ~first:i ~last:(i+2) in - if (c < 0 || c > 255) then - if in_comment () - then 'x' - else - illegal_escape lexbuf - (Printf.sprintf - "%d is outside the range of legal characters (0-255)." c) - else Char.chr c - -let char_for_octal_code lexbuf i = - let c = num_value lexbuf ~base:8 ~first:i ~last:(i+2) in - if (c < 0 || c > 255) then - if in_comment () - then 'x' - else - illegal_escape lexbuf - (Printf.sprintf - "o%o (=%d) is outside the range of legal characters (0-255)." c c) - else Char.chr c - -let char_for_hexadecimal_code lexbuf i = - Char.chr (num_value lexbuf ~base:16 ~first:i ~last:(i+1)) - -let uchar_for_uchar_escape lexbuf = - let len = Lexing.lexeme_end lexbuf - Lexing.lexeme_start lexbuf in - let first = 3 (* skip opening \u{ *) in - let last = len - 2 (* skip closing } *) in - let digit_count = last - first + 1 in - match digit_count > 6 with - | true -> - illegal_escape lexbuf - "too many digits, expected 1 to 6 hexadecimal digits" - | false -> - let cp = num_value lexbuf ~base:16 ~first ~last in - if Uchar.is_valid cp then Uchar.unsafe_of_int cp else - illegal_escape lexbuf - (Printf.sprintf "%X is not a Unicode scalar value" cp) - -let is_keyword name = Hashtbl.mem keyword_table name - -let check_label_name lexbuf name = - if is_keyword name then error lexbuf (Keyword_as_label name) - -(* Update the current location with file name and line number. *) - -let update_loc lexbuf file line absolute chars = - let pos = lexbuf.lex_curr_p in - let new_file = match file with - | None -> pos.pos_fname - | Some s -> s - in - lexbuf.lex_curr_p <- { pos with - pos_fname = new_file; - pos_lnum = if absolute then line else pos.pos_lnum + line; - pos_bol = pos.pos_cnum - chars; - } - -let preprocessor = ref None - -let escaped_newlines = ref false - -(* Warn about Latin-1 characters used in idents *) - -let warn_latin1 lexbuf = - Location.deprecated - (Location.curr lexbuf) - "ISO-Latin1 characters in identifiers" - -let handle_docstrings = ref true -let comment_list = ref [] - -let add_comment com = - comment_list := com :: !comment_list - -let add_docstring_comment ds = - let com = - ("*" ^ Docstrings.docstring_body ds, Docstrings.docstring_loc ds) - in - add_comment com - -let comments () = List.rev !comment_list - -(* Error report *) - -open Format - -let prepare_error loc = function - | Illegal_character c -> - Location.errorf ~loc "Illegal character (%s)" (Char.escaped c) - | Illegal_escape (s, explanation) -> - Location.errorf ~loc - "Illegal backslash escape in string or character (%s)%t" s - (fun ppf -> match explanation with - | None -> () - | Some expl -> fprintf ppf ": %s" expl) - | Reserved_sequence (s, explanation) -> - Location.errorf ~loc - "Reserved character sequence: %s%t" s - (fun ppf -> match explanation with - | None -> () - | Some expl -> fprintf ppf " %s" expl) - | Unterminated_comment _ -> - Location.errorf ~loc "Comment not terminated" - | Unterminated_string -> - Location.errorf ~loc "String literal not terminated" - | Unterminated_string_in_comment (_, literal_loc) -> - Location.errorf ~loc - "This comment contains an unterminated string literal" - ~sub:[Location.msg ~loc:literal_loc "String literal begins here"] - | Empty_character_literal -> - let msg = "Illegal empty character literal ''" in - let sub = - [Location.msg - "@{Hint@}: Did you mean ' ' or a type variable 'a?"] in - Location.error ~loc ~sub msg - | Keyword_as_label kwd -> - Location.errorf ~loc - "`%s' is a keyword, it cannot be used as label name" kwd - | Invalid_literal s -> - Location.errorf ~loc "Invalid literal %s" s - | Invalid_directive (dir, explanation) -> - Location.errorf ~loc "Invalid lexer directive %S%t" dir - (fun ppf -> match explanation with - | None -> () - | Some expl -> fprintf ppf ": %s" expl) - -let () = - Location.register_error_of_exn - (function - | Error (err, loc) -> - Some (prepare_error loc err) - | _ -> - None - ) - -} - -let newline = ('\013'* '\010') -let blank = [' ' '\009' '\012'] -let lowercase = ['a'-'z' '_'] -let uppercase = ['A'-'Z'] -let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9'] -let lowercase_latin1 = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] -let uppercase_latin1 = ['A'-'Z' '\192'-'\214' '\216'-'\222'] -let identchar_latin1 = - ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] -(* This should be kept in sync with the [is_identchar] function in [env.ml] *) - -let symbolchar = - ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] -let dotsymbolchar = - ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|'] -let symbolchar_or_hash = - symbolchar | '#' -let kwdopchar = - ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|'] - -let ident = (lowercase | uppercase) identchar* -let extattrident = ident ('.' ident)* - -let decimal_literal = - ['0'-'9'] ['0'-'9' '_']* -let hex_digit = - ['0'-'9' 'A'-'F' 'a'-'f'] -let hex_literal = - '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']* -let oct_literal = - '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* -let bin_literal = - '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* -let int_literal = - decimal_literal | hex_literal | oct_literal | bin_literal -let float_literal = - ['0'-'9'] ['0'-'9' '_']* - ('.' ['0'-'9' '_']* )? - (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )? -let hex_float_literal = - '0' ['x' 'X'] - ['0'-'9' 'A'-'F' 'a'-'f'] ['0'-'9' 'A'-'F' 'a'-'f' '_']* - ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )? - (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )? -let literal_modifier = ['G'-'Z' 'g'-'z'] - -rule token = parse - | ('\\' as bs) newline { - if not !escaped_newlines then error lexbuf (Illegal_character bs); - update_loc lexbuf None 1 false 0; - token lexbuf } - | newline - { update_loc lexbuf None 1 false 0; - EOL } - | blank + - { token lexbuf } - | "_" - { UNDERSCORE } - | "~" - { TILDE } - | ".~" - { error lexbuf - (Reserved_sequence (".~", Some "is reserved for use in MetaOCaml")) } - | "~" (lowercase identchar * as name) ':' - { check_label_name lexbuf name; - LABEL name } - | "~" (lowercase_latin1 identchar_latin1 * as name) ':' - { warn_latin1 lexbuf; - LABEL name } - | "?" - { QUESTION } - | "?" (lowercase identchar * as name) ':' - { check_label_name lexbuf name; - OPTLABEL name } - | "?" (lowercase_latin1 identchar_latin1 * as name) ':' - { warn_latin1 lexbuf; - OPTLABEL name } - | lowercase identchar * as name - { try Hashtbl.find keyword_table name - with Not_found -> LIDENT name } - | lowercase_latin1 identchar_latin1 * as name - { warn_latin1 lexbuf; LIDENT name } - | uppercase identchar * as name - { UIDENT name } (* No capitalized keywords *) - | uppercase_latin1 identchar_latin1 * as name - { warn_latin1 lexbuf; UIDENT name } - | int_literal as lit { INT (lit, None) } - | (int_literal as lit) (literal_modifier as modif) - { INT (lit, Some modif) } - | float_literal | hex_float_literal as lit - { FLOAT (lit, None) } - | (float_literal | hex_float_literal as lit) (literal_modifier as modif) - { FLOAT (lit, Some modif) } - | (float_literal | hex_float_literal | int_literal) identchar+ as invalid - { error lexbuf (Invalid_literal invalid) } - | "\"" - { let s, loc = wrap_string_lexer string lexbuf in - STRING (s, loc, None) } - | "{" (lowercase* as delim) "|" - { let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in - STRING (s, loc, Some delim) } - | "{%" (extattrident as id) "|" - { let orig_loc = Location.curr lexbuf in - let s, loc = wrap_string_lexer (quoted_string "") lexbuf in - let idloc = compute_quoted_string_idloc orig_loc 2 id in - QUOTED_STRING_EXPR (id, idloc, s, loc, Some "") } - | "{%" (extattrident as id) blank+ (lowercase* as delim) "|" - { let orig_loc = Location.curr lexbuf in - let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in - let idloc = compute_quoted_string_idloc orig_loc 2 id in - QUOTED_STRING_EXPR (id, idloc, s, loc, Some delim) } - | "{%%" (extattrident as id) "|" - { let orig_loc = Location.curr lexbuf in - let s, loc = wrap_string_lexer (quoted_string "") lexbuf in - let idloc = compute_quoted_string_idloc orig_loc 3 id in - QUOTED_STRING_ITEM (id, idloc, s, loc, Some "") } - | "{%%" (extattrident as id) blank+ (lowercase* as delim) "|" - { let orig_loc = Location.curr lexbuf in - let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in - let idloc = compute_quoted_string_idloc orig_loc 3 id in - QUOTED_STRING_ITEM (id, idloc, s, loc, Some delim) } - | "\'" newline "\'" - { update_loc lexbuf None 1 false 1; - (* newline is ('\013'* '\010') *) - CHAR '\n' } - | "\'" ([^ '\\' '\'' '\010' '\013'] as c) "\'" - { CHAR c } - | "\'\\" (['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] as c) "\'" - { CHAR (char_for_backslash c) } - | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'" - { CHAR(char_for_decimal_code lexbuf 2) } - | "\'\\" 'o' ['0'-'7'] ['0'-'7'] ['0'-'7'] "\'" - { CHAR(char_for_octal_code lexbuf 3) } - | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'" - { CHAR(char_for_hexadecimal_code lexbuf 3) } - | "\'" ("\\" _ as esc) - { error lexbuf (Illegal_escape (esc, None)) } - | "\'\'" - { error lexbuf Empty_character_literal } - | "(*" - { let s, loc = wrap_comment_lexer comment lexbuf in - COMMENT (s, loc) } - | "(**" - { let s, loc = wrap_comment_lexer comment lexbuf in - if !handle_docstrings then - DOCSTRING (Docstrings.docstring s loc) - else - COMMENT ("*" ^ s, loc) - } - | "(**" (('*'+) as stars) - { let s, loc = - wrap_comment_lexer - (fun lexbuf -> - store_string ("*" ^ stars); - comment lexbuf) - lexbuf - in - COMMENT (s, loc) } - | "(*)" - { if !print_warnings then - Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start; - let s, loc = wrap_comment_lexer comment lexbuf in - COMMENT (s, loc) } - | "(*" (('*'*) as stars) "*)" - { if !handle_docstrings && stars="" then - (* (**) is an empty docstring *) - DOCSTRING(Docstrings.docstring "" (Location.curr lexbuf)) - else - COMMENT (stars, Location.curr lexbuf) } - | "*)" - { let loc = Location.curr lexbuf in - Location.prerr_warning loc Warnings.Comment_not_end; - lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; - let curpos = lexbuf.lex_curr_p in - lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 }; - STAR - } - | "#" - { let at_beginning_of_line pos = (pos.pos_cnum = pos.pos_bol) in - if not (at_beginning_of_line lexbuf.lex_start_p) - then HASH - else try directive lexbuf with Failure _ -> HASH - } - | "&" { AMPERSAND } - | "&&" { AMPERAMPER } - | "`" { BACKQUOTE } - | "\'" { QUOTE } - | "(" { LPAREN } - | ")" { RPAREN } - | "*" { STAR } - | "," { COMMA } - | "->" { MINUSGREATER } - | "." { DOT } - | ".." { DOTDOT } - | "." (dotsymbolchar symbolchar* as op) { DOTOP op } - | ":" { COLON } - | "::" { COLONCOLON } - | ":=" { COLONEQUAL } - | ":>" { COLONGREATER } - | ";" { SEMI } - | ";;" { SEMISEMI } - | "<" { LESS } - | "<-" { LESSMINUS } - | "=" { EQUAL } - | "[" { LBRACKET } - | "[|" { LBRACKETBAR } - | "[<" { LBRACKETLESS } - | "[>" { LBRACKETGREATER } - | "]" { RBRACKET } - | "{" { LBRACE } - | "{<" { LBRACELESS } - | "|" { BAR } - | "||" { BARBAR } - | "|]" { BARRBRACKET } - | ">" { GREATER } - | ">]" { GREATERRBRACKET } - | "}" { RBRACE } - | ">}" { GREATERRBRACE } - | "[@" { LBRACKETAT } - | "[@@" { LBRACKETATAT } - | "[@@@" { LBRACKETATATAT } - | "[%" { LBRACKETPERCENT } - | "[%%" { LBRACKETPERCENTPERCENT } - | "!" { BANG } - | "!=" { INFIXOP0 "!=" } - | "+" { PLUS } - | "+." { PLUSDOT } - | "+=" { PLUSEQ } - | "-" { MINUS } - | "-." { MINUSDOT } - - | "!" symbolchar_or_hash + as op - { PREFIXOP op } - | ['~' '?'] symbolchar_or_hash + as op - { PREFIXOP op } - | ['=' '<' '>' '|' '&' '$'] symbolchar * as op - { INFIXOP0 op } - | ['@' '^'] symbolchar * as op - { INFIXOP1 op } - | ['+' '-'] symbolchar * as op - { INFIXOP2 op } - | "**" symbolchar * as op - { INFIXOP4 op } - | '%' { PERCENT } - | ['*' '/' '%'] symbolchar * as op - { INFIXOP3 op } - | '#' symbolchar_or_hash + as op - { HASHOP op } - | "let" kwdopchar dotsymbolchar * as op - { LETOP op } - | "and" kwdopchar dotsymbolchar * as op - { ANDOP op } - | eof { EOF } - | (_ as illegal_char) - { error lexbuf (Illegal_character illegal_char) } - -and directive = parse - | ([' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* - ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"") as directive) - [^ '\010' '\013'] * - { - match int_of_string num with - | exception _ -> - (* PR#7165 *) - let explanation = "line number out of range" in - error lexbuf (Invalid_directive ("#" ^ directive, Some explanation)) - | line_num -> - (* Documentation says that the line number should be - positive, but we have never guarded against this and it - might have useful hackish uses. *) - update_loc lexbuf (Some name) (line_num - 1) true 0; - token lexbuf - } -and comment = parse - "(*" - { comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc; - store_lexeme lexbuf; - comment lexbuf - } - | "*)" - { match !comment_start_loc with - | [] -> assert false - | [_] -> comment_start_loc := []; Location.curr lexbuf - | _ :: l -> comment_start_loc := l; - store_lexeme lexbuf; - comment lexbuf - } - | "\"" - { - string_start_loc := Location.curr lexbuf; - store_string_char '\"'; - is_in_string := true; - let _loc = try string lexbuf - with Error (Unterminated_string, str_start) -> - match !comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev !comment_start_loc) in - comment_start_loc := []; - error_loc loc (Unterminated_string_in_comment (start, str_start)) - in - is_in_string := false; - store_string_char '\"'; - comment lexbuf } - | "{" ('%' '%'? extattrident blank*)? (lowercase* as delim) "|" - { - string_start_loc := Location.curr lexbuf; - store_lexeme lexbuf; - is_in_string := true; - let _loc = try quoted_string delim lexbuf - with Error (Unterminated_string, str_start) -> - match !comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev !comment_start_loc) in - comment_start_loc := []; - error_loc loc (Unterminated_string_in_comment (start, str_start)) - in - is_in_string := false; - store_string_char '|'; - store_string delim; - store_string_char '}'; - comment lexbuf } - | "\'\'" - { store_lexeme lexbuf; comment lexbuf } - | "\'" newline "\'" - { update_loc lexbuf None 1 false 1; - store_lexeme lexbuf; - comment lexbuf - } - | "\'" [^ '\\' '\'' '\010' '\013' ] "\'" - { store_lexeme lexbuf; comment lexbuf } - | "\'\\" ['\\' '\"' '\'' 'n' 't' 'b' 'r' ' '] "\'" - { store_lexeme lexbuf; comment lexbuf } - | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'" - { store_lexeme lexbuf; comment lexbuf } - | "\'\\" 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] "\'" - { store_lexeme lexbuf; comment lexbuf } - | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'" - { store_lexeme lexbuf; comment lexbuf } - | eof - { match !comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev !comment_start_loc) in - comment_start_loc := []; - error_loc loc (Unterminated_comment start) - } - | newline - { update_loc lexbuf None 1 false 0; - store_lexeme lexbuf; - comment lexbuf - } - | ident - { store_lexeme lexbuf; comment lexbuf } - | _ - { store_lexeme lexbuf; comment lexbuf } - -and string = parse - '\"' - { lexbuf.lex_start_p } - | '\\' newline ([' ' '\t'] * as space) - { update_loc lexbuf None 1 false (String.length space); - if in_comment () then store_lexeme lexbuf; - string lexbuf - } - | '\\' (['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] as c) - { store_escaped_char lexbuf (char_for_backslash c); - string lexbuf } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] - { store_escaped_char lexbuf (char_for_decimal_code lexbuf 1); - string lexbuf } - | '\\' 'o' ['0'-'7'] ['0'-'7'] ['0'-'7'] - { store_escaped_char lexbuf (char_for_octal_code lexbuf 2); - string lexbuf } - | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] - { store_escaped_char lexbuf (char_for_hexadecimal_code lexbuf 2); - string lexbuf } - | '\\' 'u' '{' hex_digit+ '}' - { store_escaped_uchar lexbuf (uchar_for_uchar_escape lexbuf); - string lexbuf } - | '\\' _ - { if not (in_comment ()) then begin -(* Should be an error, but we are very lax. - error lexbuf (Illegal_escape (Lexing.lexeme lexbuf, None)) -*) - let loc = Location.curr lexbuf in - Location.prerr_warning loc Warnings.Illegal_backslash; - end; - store_lexeme lexbuf; - string lexbuf - } - | newline - { if not (in_comment ()) then - Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string; - update_loc lexbuf None 1 false 0; - store_lexeme lexbuf; - string lexbuf - } - | eof - { is_in_string := false; - error_loc !string_start_loc Unterminated_string } - | (_ as c) - { store_string_char c; - string lexbuf } - -and quoted_string delim = parse - | newline - { update_loc lexbuf None 1 false 0; - store_lexeme lexbuf; - quoted_string delim lexbuf - } - | eof - { is_in_string := false; - error_loc !string_start_loc Unterminated_string } - | "|" (lowercase* as edelim) "}" - { - if delim = edelim then lexbuf.lex_start_p - else (store_lexeme lexbuf; quoted_string delim lexbuf) - } - | (_ as c) - { store_string_char c; - quoted_string delim lexbuf } - -and skip_hash_bang = parse - | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n" - { update_loc lexbuf None 3 false 0 } - | "#!" [^ '\n']* '\n' - { update_loc lexbuf None 1 false 0 } - | "" { () } - -{ - - let token_with_comments lexbuf = - match !preprocessor with - | None -> token lexbuf - | Some (_init, preprocess) -> preprocess token lexbuf - - type newline_state = - | NoLine (* There have been no blank lines yet. *) - | NewLine - (* There have been no blank lines, and the previous - token was a newline. *) - | BlankLine (* There have been blank lines. *) - - type doc_state = - | Initial (* There have been no docstrings yet *) - | After of docstring list - (* There have been docstrings, none of which were - preceded by a blank line *) - | Before of docstring list * docstring list * docstring list - (* There have been docstrings, some of which were - preceded by a blank line *) - - and docstring = Docstrings.docstring - - let token lexbuf = - let post_pos = lexeme_end_p lexbuf in - let attach lines docs pre_pos = - let open Docstrings in - match docs, lines with - | Initial, _ -> () - | After a, (NoLine | NewLine) -> - set_post_docstrings post_pos (List.rev a); - set_pre_docstrings pre_pos a; - | After a, BlankLine -> - set_post_docstrings post_pos (List.rev a); - set_pre_extra_docstrings pre_pos (List.rev a) - | Before(a, f, b), (NoLine | NewLine) -> - set_post_docstrings post_pos (List.rev a); - set_post_extra_docstrings post_pos - (List.rev_append f (List.rev b)); - set_floating_docstrings pre_pos (List.rev f); - set_pre_extra_docstrings pre_pos (List.rev a); - set_pre_docstrings pre_pos b - | Before(a, f, b), BlankLine -> - set_post_docstrings post_pos (List.rev a); - set_post_extra_docstrings post_pos - (List.rev_append f (List.rev b)); - set_floating_docstrings pre_pos - (List.rev_append f (List.rev b)); - set_pre_extra_docstrings pre_pos (List.rev a) - in - let rec loop lines docs lexbuf = - match token_with_comments lexbuf with - | COMMENT (s, loc) -> - add_comment (s, loc); - let lines' = - match lines with - | NoLine -> NoLine - | NewLine -> NoLine - | BlankLine -> BlankLine - in - loop lines' docs lexbuf - | EOL -> - let lines' = - match lines with - | NoLine -> NewLine - | NewLine -> BlankLine - | BlankLine -> BlankLine - in - loop lines' docs lexbuf - | DOCSTRING doc -> - Docstrings.register doc; - add_docstring_comment doc; - let docs' = - if Docstrings.docstring_body doc = "/*" then - match docs with - | Initial -> Before([], [doc], []) - | After a -> Before (a, [doc], []) - | Before(a, f, b) -> Before(a, doc :: b @ f, []) - else - match docs, lines with - | Initial, (NoLine | NewLine) -> After [doc] - | Initial, BlankLine -> Before([], [], [doc]) - | After a, (NoLine | NewLine) -> After (doc :: a) - | After a, BlankLine -> Before (a, [], [doc]) - | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b) - | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc]) - in - loop NoLine docs' lexbuf - | tok -> - attach lines docs (lexeme_start_p lexbuf); - tok - in - loop NoLine Initial lexbuf - - let init () = - is_in_string := false; - comment_start_loc := []; - comment_list := []; - match !preprocessor with - | None -> () - | Some (init, _preprocess) -> init () - - let set_preprocessor init preprocess = - escaped_newlines := true; - preprocessor := Some (init, preprocess) - -} diff --git a/parsing/parse.ml b/parsing/parse.ml deleted file mode 100644 index a8061974f4..0000000000 --- a/parsing/parse.ml +++ /dev/null @@ -1,155 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Entry points in the parser *) - -(* Skip tokens to the end of the phrase *) - -let last_token = ref Parser.EOF - -let token lexbuf = - let token = Lexer.token lexbuf in - last_token := token; - token - -let rec skip_phrase lexbuf = - match token lexbuf with - | Parser.SEMISEMI | Parser.EOF -> () - | _ -> skip_phrase lexbuf - | exception (Lexer.Error (Lexer.Unterminated_comment _, _) - | Lexer.Error (Lexer.Unterminated_string, _) - | Lexer.Error (Lexer.Reserved_sequence _, _) - | Lexer.Error (Lexer.Unterminated_string_in_comment _, _) - | Lexer.Error (Lexer.Illegal_character _, _)) -> - skip_phrase lexbuf - -let maybe_skip_phrase lexbuf = - match !last_token with - | Parser.SEMISEMI | Parser.EOF -> () - | _ -> skip_phrase lexbuf - -type 'a parser = - (Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> 'a - -let wrap (parser : 'a parser) lexbuf : 'a = - try - Docstrings.init (); - Lexer.init (); - let ast = parser token lexbuf in - Parsing.clear_parser(); - Docstrings.warn_bad_docstrings (); - last_token := Parser.EOF; - ast - with - | Lexer.Error(Lexer.Illegal_character _, _) as err - when !Location.input_name = "//toplevel//"-> - skip_phrase lexbuf; - raise err - | Syntaxerr.Error _ as err - when !Location.input_name = "//toplevel//" -> - maybe_skip_phrase lexbuf; - raise err - | Parsing.Parse_error | Syntaxerr.Escape_error -> - let loc = Location.curr lexbuf in - if !Location.input_name = "//toplevel//" - then maybe_skip_phrase lexbuf; - raise(Syntaxerr.Error(Syntaxerr.Other loc)) - -(* We pass [--strategy simplified] to Menhir, which means that we wish to use - its "simplified" strategy for handling errors. When a syntax error occurs, - the current token is replaced with an [error] token. The parser then - continues shifting and reducing, as far as possible. After (possibly) - shifting the [error] token, though, the parser remains in error-handling - mode, and does not request the next token, so the current token remains - [error]. - - In OCaml's grammar, the [error] token always appears at the end of a - production, and this production always raises an exception. In such - a situation, the strategy described above means that: - - - either the parser will not be able to shift [error], - and will raise [Parser.Error]; - - - or it will be able to shift [error] and will then reduce - a production whose semantic action raises an exception. - - In either case, the parser will not attempt to read one token past - the syntax error. *) - -let implementation = wrap Parser.implementation -and interface = wrap Parser.interface -and toplevel_phrase = wrap Parser.toplevel_phrase -and use_file = wrap Parser.use_file -and core_type = wrap Parser.parse_core_type -and expression = wrap Parser.parse_expression -and pattern = wrap Parser.parse_pattern -let module_type = wrap Parser.parse_module_type -let module_expr = wrap Parser.parse_module_expr - -let longident = wrap Parser.parse_any_longident -let val_ident = wrap Parser.parse_val_longident -let constr_ident= wrap Parser.parse_constr_longident -let extended_module_path = wrap Parser.parse_mod_ext_longident -let simple_module_path = wrap Parser.parse_mod_longident -let type_ident = wrap Parser.parse_mty_longident - -(* Error reporting for Syntaxerr *) -(* The code has been moved here so that one can reuse Pprintast.tyvar *) - -let prepare_error err = - let open Syntaxerr in - match err with - | Unclosed(opening_loc, opening, closing_loc, closing) -> - Location.errorf - ~loc:closing_loc - ~sub:[ - Location.msg ~loc:opening_loc - "This '%s' might be unmatched" opening - ] - "Syntax error: '%s' expected" closing - - | Expecting (loc, nonterm) -> - Location.errorf ~loc "Syntax error: %s expected." nonterm - | Not_expecting (loc, nonterm) -> - Location.errorf ~loc "Syntax error: %s not expected." nonterm - | Applicative_path loc -> - Location.errorf ~loc - "Syntax error: applicative paths of the form F(X).t \ - are not supported when the option -no-app-func is set." - | Variable_in_scope (loc, var) -> - Location.errorf ~loc - "In this scoped type, variable %a \ - is reserved for the local type %s." - Pprintast.tyvar var var - | Other loc -> - Location.errorf ~loc "Syntax error" - | Ill_formed_ast (loc, s) -> - Location.errorf ~loc - "broken invariant in parsetree: %s" s - | Invalid_package_type (loc, s) -> - Location.errorf ~loc "invalid package type: %s" s - | Removed_string_set loc -> - Location.errorf ~loc - "Syntax error: strings are immutable, there is no assignment \ - syntax for them.\n\ - @{Hint@}: Mutable sequences of bytes are available in \ - the Bytes module.\n\ - @{Hint@}: Did you mean to use 'Bytes.set'?" -let () = - Location.register_error_of_exn - (function - | Syntaxerr.Error err -> Some (prepare_error err) - | _ -> None - ) diff --git a/parsing/parse.mli b/parsing/parse.mli deleted file mode 100644 index 0de6b48a13..0000000000 --- a/parsing/parse.mli +++ /dev/null @@ -1,110 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Entry points in the parser - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -val implementation : Lexing.lexbuf -> Parsetree.structure -val interface : Lexing.lexbuf -> Parsetree.signature -val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase -val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list -val core_type : Lexing.lexbuf -> Parsetree.core_type -val expression : Lexing.lexbuf -> Parsetree.expression -val pattern : Lexing.lexbuf -> Parsetree.pattern -val module_type : Lexing.lexbuf -> Parsetree.module_type -val module_expr : Lexing.lexbuf -> Parsetree.module_expr - -(** The functions below can be used to parse Longident safely. *) - -val longident: Lexing.lexbuf -> Longident.t -(** - The function [longident] is guaranteed to parse all subclasses - of {!Longident.t} used in OCaml: values, constructors, simple or extended - module paths, and types or module types. - - However, this function accepts inputs which are not accepted by the - compiler, because they combine functor applications and infix operators. - In valid OCaml syntax, only value-level identifiers may end with infix - operators [Foo.( + )]. - Moreover, in value-level identifiers the module path [Foo] must be simple - ([M.N] rather than [F(X)]): functor applications may only appear in - type-level identifiers. - As a consequence, a path such as [F(X).( + )] is not a valid OCaml - identifier; but it is accepted by this function. -*) - -(** The next functions are specialized to a subclass of {!Longident.t} *) - -val val_ident: Lexing.lexbuf -> Longident.t -(** - This function parses a syntactically valid path for a value. For instance, - [x], [M.x], and [(+.)] are valid. Contrarily, [M.A], [F(X).x], and [true] - are rejected. - - Longident for OCaml's value cannot contain functor application. - The last component of the {!Longident.t} is not capitalized, - but can be an operator [A.Path.To.(.%.%.(;..)<-)] -*) - -val constr_ident: Lexing.lexbuf -> Longident.t -(** - This function parses a syntactically valid path for a variant constructor. - For instance, [A], [M.A] and [M.(::)] are valid, but both [M.a] - and [F(X).A] are rejected. - - Longident for OCaml's variant constructors cannot contain functor - application. - The last component of the {!Longident.t} is capitalized, - or it may be one the special constructors: [true],[false],[()],[[]],[(::)]. - Among those special constructors, only [(::)] can be prefixed by a module - path ([A.B.C.(::)]). -*) - - -val simple_module_path: Lexing.lexbuf -> Longident.t -(** - This function parses a syntactically valid path for a module. - For instance, [A], and [M.A] are valid, but both [M.a] - and [F(X).A] are rejected. - - Longident for OCaml's module cannot contain functor application. - The last component of the {!Longident.t} is capitalized. -*) - - -val extended_module_path: Lexing.lexbuf -> Longident.t -(** - This function parse syntactically valid path for an extended module. - For instance, [A.B] and [F(A).B] are valid. Contrarily, - [(.%())] or [[]] are both rejected. - - The last component of the {!Longident.t} is capitalized. - -*) - -val type_ident: Lexing.lexbuf -> Longident.t -(** - This function parse syntactically valid path for a type or a module type. - For instance, [A], [t], [M.t] and [F(X).t] are valid. Contrarily, - [(.%())] or [[]] are both rejected. - - In path for type and module types, only operators and special constructors - are rejected. - -*) diff --git a/parsing/parser.mly b/parsing/parser.mly deleted file mode 100644 index 7b0e3b26e6..0000000000 --- a/parsing/parser.mly +++ /dev/null @@ -1,3904 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -/* The parser definition */ - -/* The commands [make list-parse-errors] and [make generate-parse-errors] - run Menhir on a modified copy of the parser where every block of - text comprised between the markers [BEGIN AVOID] and ----------- - [END AVOID] has been removed. This file should be formatted in - such a way that this results in a clean removal of certain - symbols, productions, or declarations. */ - -%{ - -open Asttypes -open Longident -open Parsetree -open Ast_helper -open Docstrings -open Docstrings.WithMenhir - -let mkloc = Location.mkloc -let mknoloc = Location.mknoloc - -let make_loc (startpos, endpos) = { - Location.loc_start = startpos; - Location.loc_end = endpos; - Location.loc_ghost = false; -} - -let ghost_loc (startpos, endpos) = { - Location.loc_start = startpos; - Location.loc_end = endpos; - Location.loc_ghost = true; -} - -let mktyp ~loc ?attrs d = Typ.mk ~loc:(make_loc loc) ?attrs d -let mkpat ~loc d = Pat.mk ~loc:(make_loc loc) d -let mkexp ~loc d = Exp.mk ~loc:(make_loc loc) d -let mkmty ~loc ?attrs d = Mty.mk ~loc:(make_loc loc) ?attrs d -let mksig ~loc d = Sig.mk ~loc:(make_loc loc) d -let mkmod ~loc ?attrs d = Mod.mk ~loc:(make_loc loc) ?attrs d -let mkstr ~loc d = Str.mk ~loc:(make_loc loc) d -let mkclass ~loc ?attrs d = Cl.mk ~loc:(make_loc loc) ?attrs d -let mkcty ~loc ?attrs d = Cty.mk ~loc:(make_loc loc) ?attrs d - -let pstr_typext (te, ext) = - (Pstr_typext te, ext) -let pstr_primitive (vd, ext) = - (Pstr_primitive vd, ext) -let pstr_type ((nr, ext), tys) = - (Pstr_type (nr, tys), ext) -let pstr_exception (te, ext) = - (Pstr_exception te, ext) -let pstr_include (body, ext) = - (Pstr_include body, ext) -let pstr_recmodule (ext, bindings) = - (Pstr_recmodule bindings, ext) - -let psig_typext (te, ext) = - (Psig_typext te, ext) -let psig_value (vd, ext) = - (Psig_value vd, ext) -let psig_type ((nr, ext), tys) = - (Psig_type (nr, tys), ext) -let psig_typesubst ((nr, ext), tys) = - assert (nr = Recursive); (* see [no_nonrec_flag] *) - (Psig_typesubst tys, ext) -let psig_exception (te, ext) = - (Psig_exception te, ext) -let psig_include (body, ext) = - (Psig_include body, ext) - -let mkctf ~loc ?attrs ?docs d = - Ctf.mk ~loc:(make_loc loc) ?attrs ?docs d -let mkcf ~loc ?attrs ?docs d = - Cf.mk ~loc:(make_loc loc) ?attrs ?docs d - -let mkrhs rhs loc = mkloc rhs (make_loc loc) -let ghrhs rhs loc = mkloc rhs (ghost_loc loc) - -let push_loc x acc = - if x.Location.loc_ghost - then acc - else x :: acc - -let reloc_pat ~loc x = - { x with ppat_loc = make_loc loc; - ppat_loc_stack = push_loc x.ppat_loc x.ppat_loc_stack } -let reloc_exp ~loc x = - { x with pexp_loc = make_loc loc; - pexp_loc_stack = push_loc x.pexp_loc x.pexp_loc_stack } -let reloc_typ ~loc x = - { x with ptyp_loc = make_loc loc; - ptyp_loc_stack = push_loc x.ptyp_loc x.ptyp_loc_stack } - -let mkexpvar ~loc (name : string) = - mkexp ~loc (Pexp_ident(mkrhs (Lident name) loc)) - -let mkoperator = - mkexpvar - -let mkpatvar ~loc name = - mkpat ~loc (Ppat_var (mkrhs name loc)) - -(* - Ghost expressions and patterns: - expressions and patterns that do not appear explicitly in the - source file they have the loc_ghost flag set to true. - Then the profiler will not try to instrument them and the - -annot option will not try to display their type. - - Every grammar rule that generates an element with a location must - make at most one non-ghost element, the topmost one. - - How to tell whether your location must be ghost: - A location corresponds to a range of characters in the source file. - If the location contains a piece of code that is syntactically - valid (according to the documentation), and corresponds to the - AST node, then the location must be real; in all other cases, - it must be ghost. -*) -let ghexp ~loc d = Exp.mk ~loc:(ghost_loc loc) d -let ghpat ~loc d = Pat.mk ~loc:(ghost_loc loc) d -let ghtyp ~loc d = Typ.mk ~loc:(ghost_loc loc) d -let ghloc ~loc d = { txt = d; loc = ghost_loc loc } -let ghstr ~loc d = Str.mk ~loc:(ghost_loc loc) d -let ghsig ~loc d = Sig.mk ~loc:(ghost_loc loc) d - -let mkinfix arg1 op arg2 = - Pexp_apply(op, [Nolabel, arg1; Nolabel, arg2]) - -let neg_string f = - if String.length f > 0 && f.[0] = '-' - then String.sub f 1 (String.length f - 1) - else "-" ^ f - -let mkuminus ~oploc name arg = - match name, arg.pexp_desc with - | "-", Pexp_constant(Pconst_integer (n,m)) -> - Pexp_constant(Pconst_integer(neg_string n,m)) - | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) -> - Pexp_constant(Pconst_float(neg_string f, m)) - | _ -> - Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg]) - -let mkuplus ~oploc name arg = - let desc = arg.pexp_desc in - match name, desc with - | "+", Pexp_constant(Pconst_integer _) - | ("+" | "+."), Pexp_constant(Pconst_float _) -> desc - | _ -> - Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg]) - -(* TODO define an abstraction boundary between locations-as-pairs - and locations-as-Location.t; it should be clear when we move from - one world to the other *) - -let mkexp_cons_desc consloc args = - Pexp_construct(mkrhs (Lident "::") consloc, Some args) -let mkexp_cons ~loc consloc args = - mkexp ~loc (mkexp_cons_desc consloc args) - -let mkpat_cons_desc consloc args = - Ppat_construct(mkrhs (Lident "::") consloc, Some ([], args)) -let mkpat_cons ~loc consloc args = - mkpat ~loc (mkpat_cons_desc consloc args) - -let ghexp_cons_desc consloc args = - Pexp_construct(ghrhs (Lident "::") consloc, Some args) -let ghpat_cons_desc consloc args = - Ppat_construct(ghrhs (Lident "::") consloc, Some ([], args)) - -let rec mktailexp nilloc = let open Location in function - [] -> - let nil = ghloc ~loc:nilloc (Lident "[]") in - Pexp_construct (nil, None), nilloc - | e1 :: el -> - let exp_el, el_loc = mktailexp nilloc el in - let loc = (e1.pexp_loc.loc_start, snd el_loc) in - let arg = ghexp ~loc (Pexp_tuple [e1; ghexp ~loc:el_loc exp_el]) in - ghexp_cons_desc loc arg, loc - -let rec mktailpat nilloc = let open Location in function - [] -> - let nil = ghloc ~loc:nilloc (Lident "[]") in - Ppat_construct (nil, None), nilloc - | p1 :: pl -> - let pat_pl, el_loc = mktailpat nilloc pl in - let loc = (p1.ppat_loc.loc_start, snd el_loc) in - let arg = ghpat ~loc (Ppat_tuple [p1; ghpat ~loc:el_loc pat_pl]) in - ghpat_cons_desc loc arg, loc - -let mkstrexp e attrs = - { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc } - -let mkexp_constraint ~loc e (t1, t2) = - match t1, t2 with - | Some t, None -> mkexp ~loc (Pexp_constraint(e, t)) - | _, Some t -> mkexp ~loc (Pexp_coerce(e, t1, t)) - | None, None -> assert false - -let mkexp_opt_constraint ~loc e = function - | None -> e - | Some constraint_ -> mkexp_constraint ~loc e constraint_ - -let mkpat_opt_constraint ~loc p = function - | None -> p - | Some typ -> mkpat ~loc (Ppat_constraint(p, typ)) - -let syntax_error () = - raise Syntaxerr.Escape_error - -let unclosed opening_name opening_loc closing_name closing_loc = - raise(Syntaxerr.Error(Syntaxerr.Unclosed(make_loc opening_loc, opening_name, - make_loc closing_loc, closing_name))) - -let expecting loc nonterm = - raise Syntaxerr.(Error(Expecting(make_loc loc, nonterm))) - -let removed_string_set loc = - raise(Syntaxerr.Error(Syntaxerr.Removed_string_set(make_loc loc))) - -(* Using the function [not_expecting] in a semantic action means that this - syntactic form is recognized by the parser but is in fact incorrect. This - idiom is used in a few places to produce ad hoc syntax error messages. *) - -(* This idiom should be used as little as possible, because it confuses the - analyses performed by Menhir. Because Menhir views the semantic action as - opaque, it believes that this syntactic form is correct. This can lead - [make generate-parse-errors] to produce sentences that cause an early - (unexpected) syntax error and do not achieve the desired effect. This could - also lead a completion system to propose completions which in fact are - incorrect. In order to avoid these problems, the productions that use - [not_expecting] should be marked with AVOID. *) - -let not_expecting loc nonterm = - raise Syntaxerr.(Error(Not_expecting(make_loc loc, nonterm))) - -(* Helper functions for desugaring array indexing operators *) -type paren_kind = Paren | Brace | Bracket - -(* We classify the dimension of indices: Bigarray distinguishes - indices of dimension 1,2,3, or more. Similarly, user-defined - indexing operator behave differently for indices of dimension 1 - or more. -*) -type index_dim = - | One - | Two - | Three - | Many -type ('dot,'index) array_family = { - - name: - Lexing.position * Lexing.position -> 'dot -> assign:bool -> paren_kind - -> index_dim -> Longident.t Location.loc - (* - This functions computes the name of the explicit indexing operator - associated with a sugared array indexing expression. - - For instance, for builtin arrays, if Clflags.unsafe is set, - * [ a.[index] ] => [String.unsafe_get] - * [ a.{x,y} <- 1 ] => [ Bigarray.Array2.unsafe_set] - - User-defined indexing operator follows a more local convention: - * [ a .%(index)] => [ (.%()) ] - * [ a.![1;2] <- 0 ] => [(.![;..]<-)] - * [ a.My.Map.?(0) => [My.Map.(.?())] - *); - - index: - Lexing.position * Lexing.position -> paren_kind -> 'index - -> index_dim * (arg_label * expression) list - (* - [index (start,stop) paren index] computes the dimension of the - index argument and how it should be desugared when transformed - to a list of arguments for the indexing operator. - In particular, in both the Bigarray case and the user-defined case, - beyond a certain dimension, multiple indices are packed into a single - array argument: - * [ a.(x) ] => [ [One, [Nolabel, <>] ] - * [ a.{1,2} ] => [ [Two, [Nolabel, <<1>>; Nolabel, <<2>>] ] - * [ a.{1,2,3,4} ] => [ [Many, [Nolabel, <<[|1;2;3;4|]>>] ] ] - *); - -} - -let bigarray_untuplify = function - { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist - | exp -> [exp] - -let builtin_arraylike_name loc _ ~assign paren_kind n = - let opname = if assign then "set" else "get" in - let opname = if !Clflags.unsafe then "unsafe_" ^ opname else opname in - let prefix = match paren_kind with - | Paren -> Lident "Array" - | Bracket -> - if assign then removed_string_set loc - else Lident "String" - | Brace -> - let submodule_name = match n with - | One -> "Array1" - | Two -> "Array2" - | Three -> "Array3" - | Many -> "Genarray" in - Ldot(Lident "Bigarray", submodule_name) in - ghloc ~loc (Ldot(prefix,opname)) - -let builtin_arraylike_index loc paren_kind index = match paren_kind with - | Paren | Bracket -> One, [Nolabel, index] - | Brace -> - (* Multi-indices for bigarray are comma-separated ([a.{1,2,3,4}]) *) - match bigarray_untuplify index with - | [x] -> One, [Nolabel, x] - | [x;y] -> Two, [Nolabel, x; Nolabel, y] - | [x;y;z] -> Three, [Nolabel, x; Nolabel, y; Nolabel, z] - | coords -> Many, [Nolabel, ghexp ~loc (Pexp_array coords)] - -let builtin_indexing_operators : (unit, expression) array_family = - { index = builtin_arraylike_index; name = builtin_arraylike_name } - -let paren_to_strings = function - | Paren -> "(", ")" - | Bracket -> "[", "]" - | Brace -> "{", "}" - -let user_indexing_operator_name loc (prefix,ext) ~assign paren_kind n = - let name = - let assign = if assign then "<-" else "" in - let mid = match n with - | Many | Three | Two -> ";.." - | One -> "" in - let left, right = paren_to_strings paren_kind in - String.concat "" ["."; ext; left; mid; right; assign] in - let lid = match prefix with - | None -> Lident name - | Some p -> Ldot(p,name) in - ghloc ~loc lid - -let user_index loc _ index = - (* Multi-indices for user-defined operators are semicolon-separated - ([a.%[1;2;3;4]]) *) - match index with - | [a] -> One, [Nolabel, a] - | l -> Many, [Nolabel, mkexp ~loc (Pexp_array l)] - -let user_indexing_operators: - (Longident.t option * string, expression list) array_family - = { index = user_index; name = user_indexing_operator_name } - -let mk_indexop_expr array_indexing_operator ~loc - (array,dot,paren,index,set_expr) = - let assign = match set_expr with None -> false | Some _ -> true in - let n, index = array_indexing_operator.index loc paren index in - let fn = array_indexing_operator.name loc dot ~assign paren n in - let set_arg = match set_expr with - | None -> [] - | Some expr -> [Nolabel, expr] in - let args = (Nolabel,array) :: index @ set_arg in - mkexp ~loc (Pexp_apply(ghexp ~loc (Pexp_ident fn), args)) - -let indexop_unclosed_error loc_s s loc_e = - let left, right = paren_to_strings s in - unclosed left loc_s right loc_e - -let lapply ~loc p1 p2 = - if !Clflags.applicative_functors - then Lapply(p1, p2) - else raise (Syntaxerr.Error( - Syntaxerr.Applicative_path (make_loc loc))) - -(* [loc_map] could be [Location.map]. *) -let loc_map (f : 'a -> 'b) (x : 'a Location.loc) : 'b Location.loc = - { x with txt = f x.txt } - -let make_ghost x = { x with loc = { x.loc with loc_ghost = true }} - -let loc_last (id : Longident.t Location.loc) : string Location.loc = - loc_map Longident.last id - -let loc_lident (id : string Location.loc) : Longident.t Location.loc = - loc_map (fun x -> Lident x) id - -let exp_of_longident lid = - let lid = loc_map (fun id -> Lident (Longident.last id)) lid in - Exp.mk ~loc:lid.loc (Pexp_ident lid) - -let exp_of_label lbl = - Exp.mk ~loc:lbl.loc (Pexp_ident (loc_lident lbl)) - -let pat_of_label lbl = - Pat.mk ~loc:lbl.loc (Ppat_var (loc_last lbl)) - -let mk_newtypes ~loc newtypes exp = - let mkexp = mkexp ~loc in - List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp))) - newtypes exp - -let wrap_type_annotation ~loc newtypes core_type body = - let mkexp, ghtyp = mkexp ~loc, ghtyp ~loc in - let mk_newtypes = mk_newtypes ~loc in - let exp = mkexp(Pexp_constraint(body,core_type)) in - let exp = mk_newtypes newtypes exp in - (exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type))) - -let wrap_exp_attrs ~loc body (ext, attrs) = - let ghexp = ghexp ~loc in - (* todo: keep exact location for the entire attribute *) - let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in - match ext with - | None -> body - | Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []])) - -let mkexp_attrs ~loc d attrs = - wrap_exp_attrs ~loc (mkexp ~loc d) attrs - -let wrap_typ_attrs ~loc typ (ext, attrs) = - (* todo: keep exact location for the entire attribute *) - let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in - match ext with - | None -> typ - | Some id -> ghtyp ~loc (Ptyp_extension (id, PTyp typ)) - -let wrap_pat_attrs ~loc pat (ext, attrs) = - (* todo: keep exact location for the entire attribute *) - let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in - match ext with - | None -> pat - | Some id -> ghpat ~loc (Ppat_extension (id, PPat (pat, None))) - -let mkpat_attrs ~loc d attrs = - wrap_pat_attrs ~loc (mkpat ~loc d) attrs - -let wrap_class_attrs ~loc:_ body attrs = - {body with pcl_attributes = attrs @ body.pcl_attributes} -let wrap_mod_attrs ~loc:_ attrs body = - {body with pmod_attributes = attrs @ body.pmod_attributes} -let wrap_mty_attrs ~loc:_ attrs body = - {body with pmty_attributes = attrs @ body.pmty_attributes} - -let wrap_str_ext ~loc body ext = - match ext with - | None -> body - | Some id -> ghstr ~loc (Pstr_extension ((id, PStr [body]), [])) - -let wrap_mkstr_ext ~loc (item, ext) = - wrap_str_ext ~loc (mkstr ~loc item) ext - -let wrap_sig_ext ~loc body ext = - match ext with - | None -> body - | Some id -> ghsig ~loc (Psig_extension ((id, PSig [body]), [])) - -let wrap_mksig_ext ~loc (item, ext) = - wrap_sig_ext ~loc (mksig ~loc item) ext - -let mk_quotedext ~loc (id, idloc, str, strloc, delim) = - let exp_id = mkloc id idloc in - let e = ghexp ~loc (Pexp_constant (Pconst_string (str, strloc, delim))) in - (exp_id, PStr [mkstrexp e []]) - -let text_str pos = Str.text (rhs_text pos) -let text_sig pos = Sig.text (rhs_text pos) -let text_cstr pos = Cf.text (rhs_text pos) -let text_csig pos = Ctf.text (rhs_text pos) -let text_def pos = - List.map (fun def -> Ptop_def [def]) (Str.text (rhs_text pos)) - -let extra_text startpos endpos text items = - match items with - | [] -> - let post = rhs_post_text endpos in - let post_extras = rhs_post_extra_text endpos in - text post @ text post_extras - | _ :: _ -> - let pre_extras = rhs_pre_extra_text startpos in - let post_extras = rhs_post_extra_text endpos in - text pre_extras @ items @ text post_extras - -let extra_str p1 p2 items = extra_text p1 p2 Str.text items -let extra_sig p1 p2 items = extra_text p1 p2 Sig.text items -let extra_cstr p1 p2 items = extra_text p1 p2 Cf.text items -let extra_csig p1 p2 items = extra_text p1 p2 Ctf.text items -let extra_def p1 p2 items = - extra_text p1 p2 - (fun txt -> List.map (fun def -> Ptop_def [def]) (Str.text txt)) - items - -let extra_rhs_core_type ct ~pos = - let docs = rhs_info pos in - { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes } - -type let_binding = - { lb_pattern: pattern; - lb_expression: expression; - lb_constraint: value_constraint option; - lb_is_pun: bool; - lb_attributes: attributes; - lb_docs: docs Lazy.t; - lb_text: text Lazy.t; - lb_loc: Location.t; } - -type let_bindings = - { lbs_bindings: let_binding list; - lbs_rec: rec_flag; - lbs_extension: string Asttypes.loc option } - -let mklb first ~loc (p, e, typ, is_pun) attrs = - { - lb_pattern = p; - lb_expression = e; - lb_constraint=typ; - lb_is_pun = is_pun; - lb_attributes = attrs; - lb_docs = symbol_docs_lazy loc; - lb_text = (if first then empty_text_lazy - else symbol_text_lazy (fst loc)); - lb_loc = make_loc loc; - } - -let addlb lbs lb = - if lb.lb_is_pun && lbs.lbs_extension = None then syntax_error (); - { lbs with lbs_bindings = lb :: lbs.lbs_bindings } - -let mklbs ext rf lb = - let lbs = { - lbs_bindings = []; - lbs_rec = rf; - lbs_extension = ext; - } in - addlb lbs lb - -let val_of_let_bindings ~loc lbs = - let bindings = - List.map - (fun lb -> - Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes - ~docs:(Lazy.force lb.lb_docs) - ~text:(Lazy.force lb.lb_text) - ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) - lbs.lbs_bindings - in - let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in - match lbs.lbs_extension with - | None -> str - | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), [])) - -let expr_of_let_bindings ~loc lbs body = - let bindings = - List.map - (fun lb -> - Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes - ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) - lbs.lbs_bindings - in - mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body)) - (lbs.lbs_extension, []) - -let class_of_let_bindings ~loc lbs body = - let bindings = - List.map - (fun lb -> - Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes - ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) - lbs.lbs_bindings - in - (* Our use of let_bindings(no_ext) guarantees the following: *) - assert (lbs.lbs_extension = None); - mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body)) - -(* Alternatively, we could keep the generic module type in the Parsetree - and extract the package type during type-checking. In that case, - the assertions below should be turned into explicit checks. *) -let package_type_of_module_type pmty = - let err loc s = - raise (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s))) - in - let map_cstr = function - | Pwith_type (lid, ptyp) -> - let loc = ptyp.ptype_loc in - if ptyp.ptype_params <> [] then - err loc "parametrized types are not supported"; - if ptyp.ptype_cstrs <> [] then - err loc "constrained types are not supported"; - if ptyp.ptype_private <> Public then - err loc "private types are not supported"; - - (* restrictions below are checked by the 'with_constraint' rule *) - assert (ptyp.ptype_kind = Ptype_abstract); - assert (ptyp.ptype_attributes = []); - let ty = - match ptyp.ptype_manifest with - | Some ty -> ty - | None -> assert false - in - (lid, ty) - | _ -> - err pmty.pmty_loc "only 'with type t =' constraints are supported" - in - match pmty with - | {pmty_desc = Pmty_ident lid} -> (lid, [], pmty.pmty_attributes) - | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} -> - (lid, List.map map_cstr cstrs, pmty.pmty_attributes) - | _ -> - err pmty.pmty_loc - "only module type identifier and 'with type' constraints are supported" - -let mk_directive_arg ~loc k = - { pdira_desc = k; - pdira_loc = make_loc loc; - } - -let mk_directive ~loc name arg = - Ptop_dir { - pdir_name = name; - pdir_arg = arg; - pdir_loc = make_loc loc; - } - -%} - -/* Tokens */ - -/* The alias that follows each token is used by Menhir when it needs to - produce a sentence (that is, a sequence of tokens) in concrete syntax. */ - -/* Some tokens represent multiple concrete strings. In most cases, an - arbitrary concrete string can be chosen. In a few cases, one must - be careful: e.g., in PREFIXOP and INFIXOP2, one must choose a concrete - string that will not trigger a syntax error; see how [not_expecting] - is used in the definition of [type_variance]. */ - -%token AMPERAMPER "&&" -%token AMPERSAND "&" -%token AND "and" -%token AS "as" -%token ASSERT "assert" -%token BACKQUOTE "`" -%token BANG "!" -%token BAR "|" -%token BARBAR "||" -%token BARRBRACKET "|]" -%token BEGIN "begin" -%token CHAR "'a'" (* just an example *) -%token CLASS "class" -%token COLON ":" -%token COLONCOLON "::" -%token COLONEQUAL ":=" -%token COLONGREATER ":>" -%token COMMA "," -%token CONSTRAINT "constraint" -%token DO "do" -%token DONE "done" -%token DOT "." -%token DOTDOT ".." -%token DOWNTO "downto" -%token ELSE "else" -%token END "end" -%token EOF "" -%token EQUAL "=" -%token EXCEPTION "exception" -%token EXTERNAL "external" -%token FALSE "false" -%token FLOAT "42.0" (* just an example *) -%token FOR "for" -%token FUN "fun" -%token FUNCTION "function" -%token FUNCTOR "functor" -%token GREATER ">" -%token GREATERRBRACE ">}" -%token GREATERRBRACKET ">]" -%token IF "if" -%token IN "in" -%token INCLUDE "include" -%token INFIXOP0 "!=" (* just an example *) -%token INFIXOP1 "@" (* just an example *) -%token INFIXOP2 "+!" (* chosen with care; see above *) -%token INFIXOP3 "land" (* just an example *) -%token INFIXOP4 "**" (* just an example *) -%token DOTOP ".+" -%token LETOP "let*" (* just an example *) -%token ANDOP "and*" (* just an example *) -%token INHERIT "inherit" -%token INITIALIZER "initializer" -%token INT "42" (* just an example *) -%token LABEL "~label:" (* just an example *) -%token LAZY "lazy" -%token LBRACE "{" -%token LBRACELESS "{<" -%token LBRACKET "[" -%token LBRACKETBAR "[|" -%token LBRACKETLESS "[<" -%token LBRACKETGREATER "[>" -%token LBRACKETPERCENT "[%" -%token LBRACKETPERCENTPERCENT "[%%" -%token LESS "<" -%token LESSMINUS "<-" -%token LET "let" -%token LIDENT "lident" (* just an example *) -%token LPAREN "(" -%token LBRACKETAT "[@" -%token LBRACKETATAT "[@@" -%token LBRACKETATATAT "[@@@" -%token MATCH "match" -%token METHOD "method" -%token MINUS "-" -%token MINUSDOT "-." -%token MINUSGREATER "->" -%token MODULE "module" -%token MUTABLE "mutable" -%token NEW "new" -%token NONREC "nonrec" -%token OBJECT "object" -%token OF "of" -%token OPEN "open" -%token OPTLABEL "?label:" (* just an example *) -%token OR "or" -/* %token PARSER "parser" */ -%token PERCENT "%" -%token PLUS "+" -%token PLUSDOT "+." -%token PLUSEQ "+=" -%token PREFIXOP "!+" (* chosen with care; see above *) -%token PRIVATE "private" -%token QUESTION "?" -%token QUOTE "'" -%token RBRACE "}" -%token RBRACKET "]" -%token REC "rec" -%token RPAREN ")" -%token SEMI ";" -%token SEMISEMI ";;" -%token HASH "#" -%token HASHOP "##" (* just an example *) -%token SIG "sig" -%token STAR "*" -%token - STRING "\"hello\"" (* just an example *) -%token - QUOTED_STRING_EXPR "{%hello|world|}" (* just an example *) -%token - QUOTED_STRING_ITEM "{%%hello|world|}" (* just an example *) -%token STRUCT "struct" -%token THEN "then" -%token TILDE "~" -%token TO "to" -%token TRUE "true" -%token TRY "try" -%token TYPE "type" -%token UIDENT "UIdent" (* just an example *) -%token UNDERSCORE "_" -%token VAL "val" -%token VIRTUAL "virtual" -%token WHEN "when" -%token WHILE "while" -%token WITH "with" -%token COMMENT "(* comment *)" -%token DOCSTRING "(** documentation *)" - -%token EOL "\\n" (* not great, but EOL is unused *) - -/* Precedences and associativities. - -Tokens and rules have precedences. A reduce/reduce conflict is resolved -in favor of the first rule (in source file order). A shift/reduce conflict -is resolved by comparing the precedence and associativity of the token to -be shifted with those of the rule to be reduced. - -By default, a rule has the precedence of its rightmost terminal (if any). - -When there is a shift/reduce conflict between a rule and a token that -have the same precedence, it is resolved using the associativity: -if the token is left-associative, the parser will reduce; if -right-associative, the parser will shift; if non-associative, -the parser will declare a syntax error. - -We will only use associativities with operators of the kind x * x -> x -for example, in the rules of the form expr: expr BINOP expr -in all other cases, we define two precedences if needed to resolve -conflicts. - -The precedences must be listed from low to high. -*/ - -%nonassoc IN -%nonassoc below_SEMI -%nonassoc SEMI /* below EQUAL ({lbl=...; lbl=...}) */ -%nonassoc LET /* above SEMI ( ...; let ... in ...) */ -%nonassoc below_WITH -%nonassoc FUNCTION WITH /* below BAR (match ... with ...) */ -%nonassoc AND /* above WITH (module rec A: SIG with ... and ...) */ -%nonassoc THEN /* below ELSE (if ... then ...) */ -%nonassoc ELSE /* (if ... then ... else ...) */ -%nonassoc LESSMINUS /* below COLONEQUAL (lbl <- x := e) */ -%right COLONEQUAL /* expr (e := e := e) */ -%nonassoc AS -%left BAR /* pattern (p|p|p) */ -%nonassoc below_COMMA -%left COMMA /* expr/expr_comma_list (e,e,e) */ -%right MINUSGREATER /* function_type (t -> t -> t) */ -%right OR BARBAR /* expr (e || e || e) */ -%right AMPERSAND AMPERAMPER /* expr (e && e && e) */ -%nonassoc below_EQUAL -%left INFIXOP0 EQUAL LESS GREATER /* expr (e OP e OP e) */ -%right INFIXOP1 /* expr (e OP e OP e) */ -%nonassoc below_LBRACKETAT -%nonassoc LBRACKETAT -%right COLONCOLON /* expr (e :: e :: e) */ -%left INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT PLUSEQ /* expr (e OP e OP e) */ -%left PERCENT INFIXOP3 STAR /* expr (e OP e OP e) */ -%right INFIXOP4 /* expr (e OP e OP e) */ -%nonassoc prec_unary_minus prec_unary_plus /* unary - */ -%nonassoc prec_constant_constructor /* cf. simple_expr (C versus C x) */ -%nonassoc prec_constr_appl /* above AS BAR COLONCOLON COMMA */ -%nonassoc below_HASH -%nonassoc HASH /* simple_expr/toplevel_directive */ -%left HASHOP -%nonassoc below_DOT -%nonassoc DOT DOTOP -/* Finally, the first tokens of simple_expr are above everything else. */ -%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT OBJECT - LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN - NEW PREFIXOP STRING TRUE UIDENT - LBRACKETPERCENT QUOTED_STRING_EXPR - - -/* Entry points */ - -/* Several start symbols are marked with AVOID so that they are not used by - [make generate-parse-errors]. The three start symbols that we keep are - [implementation], [use_file], and [toplevel_phrase]. The latter two are - of marginal importance; only [implementation] really matters, since most - states in the automaton are reachable from it. */ - -%start implementation /* for implementation files */ -%type implementation -/* BEGIN AVOID */ -%start interface /* for interface files */ -%type interface -/* END AVOID */ -%start toplevel_phrase /* for interactive use */ -%type toplevel_phrase -%start use_file /* for the #use directive */ -%type use_file -/* BEGIN AVOID */ -%start parse_module_type -%type parse_module_type -%start parse_module_expr -%type parse_module_expr -%start parse_core_type -%type parse_core_type -%start parse_expression -%type parse_expression -%start parse_pattern -%type parse_pattern -%start parse_constr_longident -%type parse_constr_longident -%start parse_val_longident -%type parse_val_longident -%start parse_mty_longident -%type parse_mty_longident -%start parse_mod_ext_longident -%type parse_mod_ext_longident -%start parse_mod_longident -%type parse_mod_longident -%start parse_any_longident -%type parse_any_longident -/* END AVOID */ - -%% - -/* macros */ -%inline extra_str(symb): symb { extra_str $startpos $endpos $1 }; -%inline extra_sig(symb): symb { extra_sig $startpos $endpos $1 }; -%inline extra_cstr(symb): symb { extra_cstr $startpos $endpos $1 }; -%inline extra_csig(symb): symb { extra_csig $startpos $endpos $1 }; -%inline extra_def(symb): symb { extra_def $startpos $endpos $1 }; -%inline extra_text(symb): symb { extra_text $startpos $endpos $1 }; -%inline extra_rhs(symb): symb { extra_rhs_core_type $1 ~pos:$endpos($1) }; -%inline mkrhs(symb): symb - { mkrhs $1 $sloc } -; - -%inline text_str(symb): symb - { text_str $startpos @ [$1] } -%inline text_str_SEMISEMI: SEMISEMI - { text_str $startpos } -%inline text_sig(symb): symb - { text_sig $startpos @ [$1] } -%inline text_sig_SEMISEMI: SEMISEMI - { text_sig $startpos } -%inline text_def(symb): symb - { text_def $startpos @ [$1] } -%inline top_def(symb): symb - { Ptop_def [$1] } -%inline text_cstr(symb): symb - { text_cstr $startpos @ [$1] } -%inline text_csig(symb): symb - { text_csig $startpos @ [$1] } - -(* Using this %inline definition means that we do not control precisely - when [mark_rhs_docs] is called, but I don't think this matters. *) -%inline mark_rhs_docs(symb): symb - { mark_rhs_docs $startpos $endpos; - $1 } - -%inline op(symb): symb - { mkoperator ~loc:$sloc $1 } - -%inline mkloc(symb): symb - { mkloc $1 (make_loc $sloc) } - -%inline mkexp(symb): symb - { mkexp ~loc:$sloc $1 } -%inline mkpat(symb): symb - { mkpat ~loc:$sloc $1 } -%inline mktyp(symb): symb - { mktyp ~loc:$sloc $1 } -%inline mkstr(symb): symb - { mkstr ~loc:$sloc $1 } -%inline mksig(symb): symb - { mksig ~loc:$sloc $1 } -%inline mkmod(symb): symb - { mkmod ~loc:$sloc $1 } -%inline mkmty(symb): symb - { mkmty ~loc:$sloc $1 } -%inline mkcty(symb): symb - { mkcty ~loc:$sloc $1 } -%inline mkctf(symb): symb - { mkctf ~loc:$sloc $1 } -%inline mkcf(symb): symb - { mkcf ~loc:$sloc $1 } -%inline mkclass(symb): symb - { mkclass ~loc:$sloc $1 } - -%inline wrap_mkstr_ext(symb): symb - { wrap_mkstr_ext ~loc:$sloc $1 } -%inline wrap_mksig_ext(symb): symb - { wrap_mksig_ext ~loc:$sloc $1 } - -%inline mk_directive_arg(symb): symb - { mk_directive_arg ~loc:$sloc $1 } - -/* Generic definitions */ - -(* [iloption(X)] recognizes either nothing or [X]. Assuming [X] produces - an OCaml list, it produces an OCaml list, too. *) - -%inline iloption(X): - /* nothing */ - { [] } -| x = X - { x } - -(* [llist(X)] recognizes a possibly empty list of [X]s. It is left-recursive. *) - -reversed_llist(X): - /* empty */ - { [] } -| xs = reversed_llist(X) x = X - { x :: xs } - -%inline llist(X): - xs = rev(reversed_llist(X)) - { xs } - -(* [reversed_nonempty_llist(X)] recognizes a nonempty list of [X]s, and produces - an OCaml list in reverse order -- that is, the last element in the input text - appears first in this list. Its definition is left-recursive. *) - -reversed_nonempty_llist(X): - x = X - { [ x ] } -| xs = reversed_nonempty_llist(X) x = X - { x :: xs } - -(* [nonempty_llist(X)] recognizes a nonempty list of [X]s, and produces an OCaml - list in direct order -- that is, the first element in the input text appears - first in this list. *) - -%inline nonempty_llist(X): - xs = rev(reversed_nonempty_llist(X)) - { xs } - -(* [reversed_separated_nonempty_llist(separator, X)] recognizes a nonempty list - of [X]s, separated with [separator]s, and produces an OCaml list in reverse - order -- that is, the last element in the input text appears first in this - list. Its definition is left-recursive. *) - -(* [inline_reversed_separated_nonempty_llist(separator, X)] is semantically - equivalent to [reversed_separated_nonempty_llist(separator, X)], but is - marked %inline, which means that the case of a list of length one and - the case of a list of length more than one will be distinguished at the - use site, and will give rise there to two productions. This can be used - to avoid certain conflicts. *) - -%inline inline_reversed_separated_nonempty_llist(separator, X): - x = X - { [ x ] } -| xs = reversed_separated_nonempty_llist(separator, X) - separator - x = X - { x :: xs } - -reversed_separated_nonempty_llist(separator, X): - xs = inline_reversed_separated_nonempty_llist(separator, X) - { xs } - -(* [separated_nonempty_llist(separator, X)] recognizes a nonempty list of [X]s, - separated with [separator]s, and produces an OCaml list in direct order -- - that is, the first element in the input text appears first in this list. *) - -%inline separated_nonempty_llist(separator, X): - xs = rev(reversed_separated_nonempty_llist(separator, X)) - { xs } - -%inline inline_separated_nonempty_llist(separator, X): - xs = rev(inline_reversed_separated_nonempty_llist(separator, X)) - { xs } - -(* [reversed_separated_nontrivial_llist(separator, X)] recognizes a list of at - least two [X]s, separated with [separator]s, and produces an OCaml list in - reverse order -- that is, the last element in the input text appears first - in this list. Its definition is left-recursive. *) - -reversed_separated_nontrivial_llist(separator, X): - xs = reversed_separated_nontrivial_llist(separator, X) - separator - x = X - { x :: xs } -| x1 = X - separator - x2 = X - { [ x2; x1 ] } - -(* [separated_nontrivial_llist(separator, X)] recognizes a list of at least - two [X]s, separated with [separator]s, and produces an OCaml list in direct - order -- that is, the first element in the input text appears first in this - list. *) - -%inline separated_nontrivial_llist(separator, X): - xs = rev(reversed_separated_nontrivial_llist(separator, X)) - { xs } - -(* [separated_or_terminated_nonempty_list(delimiter, X)] recognizes a nonempty - list of [X]s, separated with [delimiter]s, and optionally terminated with a - final [delimiter]. Its definition is right-recursive. *) - -separated_or_terminated_nonempty_list(delimiter, X): - x = X ioption(delimiter) - { [x] } -| x = X - delimiter - xs = separated_or_terminated_nonempty_list(delimiter, X) - { x :: xs } - -(* [reversed_preceded_or_separated_nonempty_llist(delimiter, X)] recognizes a - nonempty list of [X]s, separated with [delimiter]s, and optionally preceded - with a leading [delimiter]. It produces an OCaml list in reverse order. Its - definition is left-recursive. *) - -reversed_preceded_or_separated_nonempty_llist(delimiter, X): - ioption(delimiter) x = X - { [x] } -| xs = reversed_preceded_or_separated_nonempty_llist(delimiter, X) - delimiter - x = X - { x :: xs } - -(* [preceded_or_separated_nonempty_llist(delimiter, X)] recognizes a nonempty - list of [X]s, separated with [delimiter]s, and optionally preceded with a - leading [delimiter]. It produces an OCaml list in direct order. *) - -%inline preceded_or_separated_nonempty_llist(delimiter, X): - xs = rev(reversed_preceded_or_separated_nonempty_llist(delimiter, X)) - { xs } - -(* [bar_llist(X)] recognizes a nonempty list of [X]'s, separated with BARs, - with an optional leading BAR. We assume that [X] is itself parameterized - with an opening symbol, which can be [epsilon] or [BAR]. *) - -(* This construction may seem needlessly complicated: one might think that - using [preceded_or_separated_nonempty_llist(BAR, X)], where [X] is *not* - itself parameterized, would be sufficient. Indeed, this simpler approach - would recognize the same language. However, the two approaches differ in - the footprint of [X]. We want the start location of [X] to include [BAR] - when present. In the future, we might consider switching to the simpler - definition, at the cost of producing slightly different locations. TODO *) - -reversed_bar_llist(X): - (* An [X] without a leading BAR. *) - x = X(epsilon) - { [x] } - | (* An [X] with a leading BAR. *) - x = X(BAR) - { [x] } - | (* An initial list, followed with a BAR and an [X]. *) - xs = reversed_bar_llist(X) - x = X(BAR) - { x :: xs } - -%inline bar_llist(X): - xs = reversed_bar_llist(X) - { List.rev xs } - -(* [xlist(A, B)] recognizes [AB*]. We assume that the semantic value for [A] - is a pair [x, b], while the semantic value for [B*] is a list [bs]. - We return the pair [x, b :: bs]. *) - -%inline xlist(A, B): - a = A bs = B* - { let (x, b) = a in x, b :: bs } - -(* [listx(delimiter, X, Y)] recognizes a nonempty list of [X]s, optionally - followed with a [Y], separated-or-terminated with [delimiter]s. The - semantic value is a pair of a list of [X]s and an optional [Y]. *) - -listx(delimiter, X, Y): -| x = X ioption(delimiter) - { [x], None } -| x = X delimiter y = Y delimiter? - { [x], Some y } -| x = X - delimiter - tail = listx(delimiter, X, Y) - { let xs, y = tail in - x :: xs, y } - -(* -------------------------------------------------------------------------- *) - -(* Entry points. *) - -(* An .ml file. *) -implementation: - structure EOF - { $1 } -; - -/* BEGIN AVOID */ -(* An .mli file. *) -interface: - signature EOF - { $1 } -; -/* END AVOID */ - -(* A toplevel phrase. *) -toplevel_phrase: - (* An expression with attributes, ended by a double semicolon. *) - extra_str(text_str(str_exp)) - SEMISEMI - { Ptop_def $1 } -| (* A list of structure items, ended by a double semicolon. *) - extra_str(flatten(text_str(structure_item)*)) - SEMISEMI - { Ptop_def $1 } -| (* A directive, ended by a double semicolon. *) - toplevel_directive - SEMISEMI - { $1 } -| (* End of input. *) - EOF - { raise End_of_file } -; - -(* An .ml file that is read by #use. *) -use_file: - (* An optional standalone expression, - followed with a series of elements, - followed with EOF. *) - extra_def(append( - optional_use_file_standalone_expression, - flatten(use_file_element*) - )) - EOF - { $1 } -; - -(* An optional standalone expression is just an expression with attributes - (str_exp), with extra wrapping. *) -%inline optional_use_file_standalone_expression: - iloption(text_def(top_def(str_exp))) - { $1 } -; - -(* An element in a #used file is one of the following: - - a double semicolon followed with an optional standalone expression; - - a structure item; - - a toplevel directive. - *) -%inline use_file_element: - preceded(SEMISEMI, optional_use_file_standalone_expression) -| text_def(top_def(structure_item)) -| text_def(mark_rhs_docs(toplevel_directive)) - { $1 } -; - -/* BEGIN AVOID */ -parse_module_type: - module_type EOF - { $1 } -; - -parse_module_expr: - module_expr EOF - { $1 } -; - -parse_core_type: - core_type EOF - { $1 } -; - -parse_expression: - seq_expr EOF - { $1 } -; - -parse_pattern: - pattern EOF - { $1 } -; - -parse_mty_longident: - mty_longident EOF - { $1 } -; - -parse_val_longident: - val_longident EOF - { $1 } -; - -parse_constr_longident: - constr_longident EOF - { $1 } -; - -parse_mod_ext_longident: - mod_ext_longident EOF - { $1 } -; - -parse_mod_longident: - mod_longident EOF - { $1 } -; - -parse_any_longident: - any_longident EOF - { $1 } -; -/* END AVOID */ - -(* -------------------------------------------------------------------------- *) - -(* Functor arguments appear in module expressions and module types. *) - -%inline functor_args: - reversed_nonempty_llist(functor_arg) - { $1 } - (* Produce a reversed list on purpose; - later processed using [fold_left]. *) -; - -functor_arg: - (* An anonymous and untyped argument. *) - LPAREN RPAREN - { $startpos, Unit } - | (* An argument accompanied with an explicit type. *) - LPAREN x = mkrhs(module_name) COLON mty = module_type RPAREN - { $startpos, Named (x, mty) } -; - -module_name: - (* A named argument. *) - x = UIDENT - { Some x } - | (* An anonymous argument. *) - UNDERSCORE - { None } -; - -(* -------------------------------------------------------------------------- *) - -(* Module expressions. *) - -(* The syntax of module expressions is not properly stratified. The cases of - functors, functor applications, and attributes interact and cause conflicts, - which are resolved by precedence declarations. This is concise but fragile. - Perhaps in the future an explicit stratification could be used. *) - -module_expr: - | STRUCT attrs = attributes s = structure END - { mkmod ~loc:$sloc ~attrs (Pmod_structure s) } - | STRUCT attributes structure error - { unclosed "struct" $loc($1) "end" $loc($4) } - | SIG error - { expecting $loc($1) "struct" } - | FUNCTOR attrs = attributes args = functor_args MINUSGREATER me = module_expr - { wrap_mod_attrs ~loc:$sloc attrs ( - List.fold_left (fun acc (startpos, arg) -> - mkmod ~loc:(startpos, $endpos) (Pmod_functor (arg, acc)) - ) me args - ) } - | me = paren_module_expr - { me } - | me = module_expr attr = attribute - { Mod.attr me attr } - | mkmod( - (* A module identifier. *) - x = mkrhs(mod_longident) - { Pmod_ident x } - | (* In a functor application, the actual argument must be parenthesized. *) - me1 = module_expr me2 = paren_module_expr - { Pmod_apply(me1, me2) } - | (* Functor applied to unit. *) - me = module_expr LPAREN RPAREN - { Pmod_apply_unit me } - | (* An extension. *) - ex = extension - { Pmod_extension ex } - ) - { $1 } -; - -(* A parenthesized module expression is a module expression that begins - and ends with parentheses. *) - -paren_module_expr: - (* A module expression annotated with a module type. *) - LPAREN me = module_expr COLON mty = module_type RPAREN - { mkmod ~loc:$sloc (Pmod_constraint(me, mty)) } - | LPAREN module_expr COLON module_type error - { unclosed "(" $loc($1) ")" $loc($5) } - | (* A module expression within parentheses. *) - LPAREN me = module_expr RPAREN - { me (* TODO consider reloc *) } - | LPAREN module_expr error - { unclosed "(" $loc($1) ")" $loc($3) } - | (* A core language expression that produces a first-class module. - This expression can be annotated in various ways. *) - LPAREN VAL attrs = attributes e = expr_colon_package_type RPAREN - { mkmod ~loc:$sloc ~attrs (Pmod_unpack e) } - | LPAREN VAL attributes expr COLON error - { unclosed "(" $loc($1) ")" $loc($6) } - | LPAREN VAL attributes expr COLONGREATER error - { unclosed "(" $loc($1) ")" $loc($6) } - | LPAREN VAL attributes expr error - { unclosed "(" $loc($1) ")" $loc($5) } -; - -(* The various ways of annotating a core language expression that - produces a first-class module that we wish to unpack. *) -%inline expr_colon_package_type: - e = expr - { e } - | e = expr COLON ty = package_type - { ghexp ~loc:$loc (Pexp_constraint (e, ty)) } - | e = expr COLON ty1 = package_type COLONGREATER ty2 = package_type - { ghexp ~loc:$loc (Pexp_coerce (e, Some ty1, ty2)) } - | e = expr COLONGREATER ty2 = package_type - { ghexp ~loc:$loc (Pexp_coerce (e, None, ty2)) } -; - -(* A structure, which appears between STRUCT and END (among other places), - begins with an optional standalone expression, and continues with a list - of structure elements. *) -structure: - extra_str(append( - optional_structure_standalone_expression, - flatten(structure_element*) - )) - { $1 } -; - -(* An optional standalone expression is just an expression with attributes - (str_exp), with extra wrapping. *) -%inline optional_structure_standalone_expression: - items = iloption(mark_rhs_docs(text_str(str_exp))) - { items } -; - -(* An expression with attributes, wrapped as a structure item. *) -%inline str_exp: - e = seq_expr - attrs = post_item_attributes - { mkstrexp e attrs } -; - -(* A structure element is one of the following: - - a double semicolon followed with an optional standalone expression; - - a structure item. *) -%inline structure_element: - append(text_str_SEMISEMI, optional_structure_standalone_expression) - | text_str(structure_item) - { $1 } -; - -(* A structure item. *) -structure_item: - let_bindings(ext) - { val_of_let_bindings ~loc:$sloc $1 } - | mkstr( - item_extension post_item_attributes - { let docs = symbol_docs $sloc in - Pstr_extension ($1, add_docs_attrs docs $2) } - | floating_attribute - { Pstr_attribute $1 } - ) - | wrap_mkstr_ext( - primitive_declaration - { pstr_primitive $1 } - | value_description - { pstr_primitive $1 } - | type_declarations - { pstr_type $1 } - | str_type_extension - { pstr_typext $1 } - | str_exception_declaration - { pstr_exception $1 } - | module_binding - { $1 } - | rec_module_bindings - { pstr_recmodule $1 } - | module_type_declaration - { let (body, ext) = $1 in (Pstr_modtype body, ext) } - | open_declaration - { let (body, ext) = $1 in (Pstr_open body, ext) } - | class_declarations - { let (ext, l) = $1 in (Pstr_class l, ext) } - | class_type_declarations - { let (ext, l) = $1 in (Pstr_class_type l, ext) } - | include_statement(module_expr) - { pstr_include $1 } - ) - { $1 } -; - -(* A single module binding. *) -%inline module_binding: - MODULE - ext = ext attrs1 = attributes - name = mkrhs(module_name) - body = module_binding_body - attrs2 = post_item_attributes - { let docs = symbol_docs $sloc in - let loc = make_loc $sloc in - let attrs = attrs1 @ attrs2 in - let body = Mb.mk name body ~attrs ~loc ~docs in - Pstr_module body, ext } -; - -(* The body (right-hand side) of a module binding. *) -module_binding_body: - EQUAL me = module_expr - { me } - | COLON error - { expecting $loc($1) "=" } - | mkmod( - COLON mty = module_type EQUAL me = module_expr - { Pmod_constraint(me, mty) } - | arg_and_pos = functor_arg body = module_binding_body - { let (_, arg) = arg_and_pos in - Pmod_functor(arg, body) } - ) { $1 } -; - -(* A group of recursive module bindings. *) -%inline rec_module_bindings: - xlist(rec_module_binding, and_module_binding) - { $1 } -; - -(* The first binding in a group of recursive module bindings. *) -%inline rec_module_binding: - MODULE - ext = ext - attrs1 = attributes - REC - name = mkrhs(module_name) - body = module_binding_body - attrs2 = post_item_attributes - { - let loc = make_loc $sloc in - let attrs = attrs1 @ attrs2 in - let docs = symbol_docs $sloc in - ext, - Mb.mk name body ~attrs ~loc ~docs - } -; - -(* The following bindings in a group of recursive module bindings. *) -%inline and_module_binding: - AND - attrs1 = attributes - name = mkrhs(module_name) - body = module_binding_body - attrs2 = post_item_attributes - { - let loc = make_loc $sloc in - let attrs = attrs1 @ attrs2 in - let docs = symbol_docs $sloc in - let text = symbol_text $symbolstartpos in - Mb.mk name body ~attrs ~loc ~text ~docs - } -; - -(* -------------------------------------------------------------------------- *) - -(* Shared material between structures and signatures. *) - -(* An [include] statement can appear in a structure or in a signature, - which is why this definition is parameterized. *) -%inline include_statement(thing): - INCLUDE - ext = ext - attrs1 = attributes - thing = thing - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - Incl.mk thing ~attrs ~loc ~docs, ext - } -; - -(* A module type declaration. *) -module_type_declaration: - MODULE TYPE - ext = ext - attrs1 = attributes - id = mkrhs(ident) - typ = preceded(EQUAL, module_type)? - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - Mtd.mk id ?typ ~attrs ~loc ~docs, ext - } -; - -(* -------------------------------------------------------------------------- *) - -(* Opens. *) - -open_declaration: - OPEN - override = override_flag - ext = ext - attrs1 = attributes - me = module_expr - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - Opn.mk me ~override ~attrs ~loc ~docs, ext - } -; - -open_description: - OPEN - override = override_flag - ext = ext - attrs1 = attributes - id = mkrhs(mod_ext_longident) - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - Opn.mk id ~override ~attrs ~loc ~docs, ext - } -; - -%inline open_dot_declaration: mkrhs(mod_longident) - { let loc = make_loc $loc($1) in - let me = Mod.ident ~loc $1 in - Opn.mk ~loc me } -; - -(* -------------------------------------------------------------------------- *) - -/* Module types */ - -module_type: - | SIG attrs = attributes s = signature END - { mkmty ~loc:$sloc ~attrs (Pmty_signature s) } - | SIG attributes signature error - { unclosed "sig" $loc($1) "end" $loc($4) } - | STRUCT error - { expecting $loc($1) "sig" } - | FUNCTOR attrs = attributes args = functor_args - MINUSGREATER mty = module_type - %prec below_WITH - { wrap_mty_attrs ~loc:$sloc attrs ( - List.fold_left (fun acc (startpos, arg) -> - mkmty ~loc:(startpos, $endpos) (Pmty_functor (arg, acc)) - ) mty args - ) } - | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT - { mkmty ~loc:$sloc ~attrs:$4 (Pmty_typeof $5) } - | LPAREN module_type RPAREN - { $2 } - | LPAREN module_type error - { unclosed "(" $loc($1) ")" $loc($3) } - | module_type attribute - { Mty.attr $1 $2 } - | mkmty( - mkrhs(mty_longident) - { Pmty_ident $1 } - | LPAREN RPAREN MINUSGREATER module_type - { Pmty_functor(Unit, $4) } - | module_type MINUSGREATER module_type - %prec below_WITH - { Pmty_functor(Named (mknoloc None, $1), $3) } - | module_type WITH separated_nonempty_llist(AND, with_constraint) - { Pmty_with($1, $3) } -/* | LPAREN MODULE mkrhs(mod_longident) RPAREN - { Pmty_alias $3 } */ - | extension - { Pmty_extension $1 } - ) - { $1 } -; -(* A signature, which appears between SIG and END (among other places), - is a list of signature elements. *) -signature: - extra_sig(flatten(signature_element*)) - { $1 } -; - -(* A signature element is one of the following: - - a double semicolon; - - a signature item. *) -%inline signature_element: - text_sig_SEMISEMI - | text_sig(signature_item) - { $1 } -; - -(* A signature item. *) -signature_item: - | item_extension post_item_attributes - { let docs = symbol_docs $sloc in - mksig ~loc:$sloc (Psig_extension ($1, (add_docs_attrs docs $2))) } - | mksig( - floating_attribute - { Psig_attribute $1 } - ) - { $1 } - | wrap_mksig_ext( - value_description - { psig_value $1 } - | primitive_declaration - { psig_value $1 } - | type_declarations - { psig_type $1 } - | type_subst_declarations - { psig_typesubst $1 } - | sig_type_extension - { psig_typext $1 } - | sig_exception_declaration - { psig_exception $1 } - | module_declaration - { let (body, ext) = $1 in (Psig_module body, ext) } - | module_alias - { let (body, ext) = $1 in (Psig_module body, ext) } - | module_subst - { let (body, ext) = $1 in (Psig_modsubst body, ext) } - | rec_module_declarations - { let (ext, l) = $1 in (Psig_recmodule l, ext) } - | module_type_declaration - { let (body, ext) = $1 in (Psig_modtype body, ext) } - | module_type_subst - { let (body, ext) = $1 in (Psig_modtypesubst body, ext) } - | open_description - { let (body, ext) = $1 in (Psig_open body, ext) } - | include_statement(module_type) - { psig_include $1 } - | class_descriptions - { let (ext, l) = $1 in (Psig_class l, ext) } - | class_type_declarations - { let (ext, l) = $1 in (Psig_class_type l, ext) } - ) - { $1 } - -(* A module declaration. *) -%inline module_declaration: - MODULE - ext = ext attrs1 = attributes - name = mkrhs(module_name) - body = module_declaration_body - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - Md.mk name body ~attrs ~loc ~docs, ext - } -; - -(* The body (right-hand side) of a module declaration. *) -module_declaration_body: - COLON mty = module_type - { mty } - | EQUAL error - { expecting $loc($1) ":" } - | mkmty( - arg_and_pos = functor_arg body = module_declaration_body - { let (_, arg) = arg_and_pos in - Pmty_functor(arg, body) } - ) - { $1 } -; - -(* A module alias declaration (in a signature). *) -%inline module_alias: - MODULE - ext = ext attrs1 = attributes - name = mkrhs(module_name) - EQUAL - body = module_expr_alias - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - Md.mk name body ~attrs ~loc ~docs, ext - } -; -%inline module_expr_alias: - id = mkrhs(mod_longident) - { Mty.alias ~loc:(make_loc $sloc) id } -; -(* A module substitution (in a signature). *) -module_subst: - MODULE - ext = ext attrs1 = attributes - uid = mkrhs(UIDENT) - COLONEQUAL - body = mkrhs(mod_ext_longident) - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - Ms.mk uid body ~attrs ~loc ~docs, ext - } -| MODULE ext attributes mkrhs(UIDENT) COLONEQUAL error - { expecting $loc($6) "module path" } -; - -(* A group of recursive module declarations. *) -%inline rec_module_declarations: - xlist(rec_module_declaration, and_module_declaration) - { $1 } -; -%inline rec_module_declaration: - MODULE - ext = ext - attrs1 = attributes - REC - name = mkrhs(module_name) - COLON - mty = module_type - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - ext, Md.mk name mty ~attrs ~loc ~docs - } -; -%inline and_module_declaration: - AND - attrs1 = attributes - name = mkrhs(module_name) - COLON - mty = module_type - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let docs = symbol_docs $sloc in - let loc = make_loc $sloc in - let text = symbol_text $symbolstartpos in - Md.mk name mty ~attrs ~loc ~text ~docs - } -; - -(* A module type substitution *) -module_type_subst: - MODULE TYPE - ext = ext - attrs1 = attributes - id = mkrhs(ident) - COLONEQUAL - typ=module_type - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - Mtd.mk id ~typ ~attrs ~loc ~docs, ext - } - - -(* -------------------------------------------------------------------------- *) - -(* Class declarations. *) - -%inline class_declarations: - xlist(class_declaration, and_class_declaration) - { $1 } -; -%inline class_declaration: - CLASS - ext = ext - attrs1 = attributes - virt = virtual_flag - params = formal_class_parameters - id = mkrhs(LIDENT) - body = class_fun_binding - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - ext, - Ci.mk id body ~virt ~params ~attrs ~loc ~docs - } -; -%inline and_class_declaration: - AND - attrs1 = attributes - virt = virtual_flag - params = formal_class_parameters - id = mkrhs(LIDENT) - body = class_fun_binding - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - let text = symbol_text $symbolstartpos in - Ci.mk id body ~virt ~params ~attrs ~loc ~text ~docs - } -; - -class_fun_binding: - EQUAL class_expr - { $2 } - | mkclass( - COLON class_type EQUAL class_expr - { Pcl_constraint($4, $2) } - | labeled_simple_pattern class_fun_binding - { let (l,o,p) = $1 in Pcl_fun(l, o, p, $2) } - ) { $1 } -; - -formal_class_parameters: - params = class_parameters(type_parameter) - { params } -; - -(* -------------------------------------------------------------------------- *) - -(* Class expressions. *) - -class_expr: - class_simple_expr - { $1 } - | FUN attributes class_fun_def - { wrap_class_attrs ~loc:$sloc $3 $2 } - | let_bindings(no_ext) IN class_expr - { class_of_let_bindings ~loc:$sloc $1 $3 } - | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_expr - { let loc = ($startpos($2), $endpos($5)) in - let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in - mkclass ~loc:$sloc ~attrs:$4 (Pcl_open(od, $7)) } - | class_expr attribute - { Cl.attr $1 $2 } - | mkclass( - class_simple_expr nonempty_llist(labeled_simple_expr) - { Pcl_apply($1, $2) } - | extension - { Pcl_extension $1 } - ) { $1 } -; -class_simple_expr: - | LPAREN class_expr RPAREN - { $2 } - | LPAREN class_expr error - { unclosed "(" $loc($1) ")" $loc($3) } - | mkclass( - tys = actual_class_parameters cid = mkrhs(class_longident) - { Pcl_constr(cid, tys) } - | OBJECT attributes class_structure error - { unclosed "object" $loc($1) "end" $loc($4) } - | LPAREN class_expr COLON class_type RPAREN - { Pcl_constraint($2, $4) } - | LPAREN class_expr COLON class_type error - { unclosed "(" $loc($1) ")" $loc($5) } - ) { $1 } - | OBJECT attributes class_structure END - { mkclass ~loc:$sloc ~attrs:$2 (Pcl_structure $3) } -; - -class_fun_def: - mkclass( - labeled_simple_pattern MINUSGREATER e = class_expr - | labeled_simple_pattern e = class_fun_def - { let (l,o,p) = $1 in Pcl_fun(l, o, p, e) } - ) { $1 } -; -%inline class_structure: - | class_self_pattern extra_cstr(class_fields) - { Cstr.mk $1 $2 } -; -class_self_pattern: - LPAREN pattern RPAREN - { reloc_pat ~loc:$sloc $2 } - | mkpat(LPAREN pattern COLON core_type RPAREN - { Ppat_constraint($2, $4) }) - { $1 } - | /* empty */ - { ghpat ~loc:$sloc Ppat_any } -; -%inline class_fields: - flatten(text_cstr(class_field)*) - { $1 } -; -class_field: - | INHERIT override_flag attributes class_expr - self = preceded(AS, mkrhs(LIDENT))? - post_item_attributes - { let docs = symbol_docs $sloc in - mkcf ~loc:$sloc (Pcf_inherit ($2, $4, self)) ~attrs:($3@$6) ~docs } - | VAL value post_item_attributes - { let v, attrs = $2 in - let docs = symbol_docs $sloc in - mkcf ~loc:$sloc (Pcf_val v) ~attrs:(attrs@$3) ~docs } - | METHOD method_ post_item_attributes - { let meth, attrs = $2 in - let docs = symbol_docs $sloc in - mkcf ~loc:$sloc (Pcf_method meth) ~attrs:(attrs@$3) ~docs } - | CONSTRAINT attributes constrain_field post_item_attributes - { let docs = symbol_docs $sloc in - mkcf ~loc:$sloc (Pcf_constraint $3) ~attrs:($2@$4) ~docs } - | INITIALIZER attributes seq_expr post_item_attributes - { let docs = symbol_docs $sloc in - mkcf ~loc:$sloc (Pcf_initializer $3) ~attrs:($2@$4) ~docs } - | item_extension post_item_attributes - { let docs = symbol_docs $sloc in - mkcf ~loc:$sloc (Pcf_extension $1) ~attrs:$2 ~docs } - | mkcf(floating_attribute - { Pcf_attribute $1 }) - { $1 } -; -value: - no_override_flag - attrs = attributes - mutable_ = virtual_with_mutable_flag - label = mkrhs(label) COLON ty = core_type - { (label, mutable_, Cfk_virtual ty), attrs } - | override_flag attributes mutable_flag mkrhs(label) EQUAL seq_expr - { ($4, $3, Cfk_concrete ($1, $6)), $2 } - | override_flag attributes mutable_flag mkrhs(label) type_constraint - EQUAL seq_expr - { let e = mkexp_constraint ~loc:$sloc $7 $5 in - ($4, $3, Cfk_concrete ($1, e)), $2 - } -; -method_: - no_override_flag - attrs = attributes - private_ = virtual_with_private_flag - label = mkrhs(label) COLON ty = poly_type - { (label, private_, Cfk_virtual ty), attrs } - | override_flag attributes private_flag mkrhs(label) strict_binding - { let e = $5 in - let loc = Location.(e.pexp_loc.loc_start, e.pexp_loc.loc_end) in - ($4, $3, - Cfk_concrete ($1, ghexp ~loc (Pexp_poly (e, None)))), $2 } - | override_flag attributes private_flag mkrhs(label) - COLON poly_type EQUAL seq_expr - { let poly_exp = - let loc = ($startpos($6), $endpos($8)) in - ghexp ~loc (Pexp_poly($8, Some $6)) in - ($4, $3, Cfk_concrete ($1, poly_exp)), $2 } - | override_flag attributes private_flag mkrhs(label) COLON TYPE lident_list - DOT core_type EQUAL seq_expr - { let poly_exp_loc = ($startpos($7), $endpos($11)) in - let poly_exp = - let exp, poly = - (* it seems odd to use the global ~loc here while poly_exp_loc - is tighter, but this is what ocamlyacc does; - TODO improve parser.mly *) - wrap_type_annotation ~loc:$sloc $7 $9 $11 in - ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in - ($4, $3, - Cfk_concrete ($1, poly_exp)), $2 } -; - -/* Class types */ - -class_type: - class_signature - { $1 } - | mkcty( - label = arg_label - domain = tuple_type - MINUSGREATER - codomain = class_type - { Pcty_arrow(label, domain, codomain) } - ) { $1 } - ; -class_signature: - mkcty( - tys = actual_class_parameters cid = mkrhs(clty_longident) - { Pcty_constr (cid, tys) } - | extension - { Pcty_extension $1 } - ) { $1 } - | OBJECT attributes class_sig_body END - { mkcty ~loc:$sloc ~attrs:$2 (Pcty_signature $3) } - | OBJECT attributes class_sig_body error - { unclosed "object" $loc($1) "end" $loc($4) } - | class_signature attribute - { Cty.attr $1 $2 } - | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_signature - { let loc = ($startpos($2), $endpos($5)) in - let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in - mkcty ~loc:$sloc ~attrs:$4 (Pcty_open(od, $7)) } -; -%inline class_parameters(parameter): - | /* empty */ - { [] } - | LBRACKET params = separated_nonempty_llist(COMMA, parameter) RBRACKET - { params } -; -%inline actual_class_parameters: - tys = class_parameters(core_type) - { tys } -; -%inline class_sig_body: - class_self_type extra_csig(class_sig_fields) - { Csig.mk $1 $2 } -; -class_self_type: - LPAREN core_type RPAREN - { $2 } - | mktyp((* empty *) { Ptyp_any }) - { $1 } -; -%inline class_sig_fields: - flatten(text_csig(class_sig_field)*) - { $1 } -; -class_sig_field: - INHERIT attributes class_signature post_item_attributes - { let docs = symbol_docs $sloc in - mkctf ~loc:$sloc (Pctf_inherit $3) ~attrs:($2@$4) ~docs } - | VAL attributes value_type post_item_attributes - { let docs = symbol_docs $sloc in - mkctf ~loc:$sloc (Pctf_val $3) ~attrs:($2@$4) ~docs } - | METHOD attributes private_virtual_flags mkrhs(label) COLON poly_type - post_item_attributes - { let (p, v) = $3 in - let docs = symbol_docs $sloc in - mkctf ~loc:$sloc (Pctf_method ($4, p, v, $6)) ~attrs:($2@$7) ~docs } - | CONSTRAINT attributes constrain_field post_item_attributes - { let docs = symbol_docs $sloc in - mkctf ~loc:$sloc (Pctf_constraint $3) ~attrs:($2@$4) ~docs } - | item_extension post_item_attributes - { let docs = symbol_docs $sloc in - mkctf ~loc:$sloc (Pctf_extension $1) ~attrs:$2 ~docs } - | mkctf(floating_attribute - { Pctf_attribute $1 }) - { $1 } -; -%inline value_type: - flags = mutable_virtual_flags - label = mkrhs(label) - COLON - ty = core_type - { - let mut, virt = flags in - label, mut, virt, ty - } -; -%inline constrain: - core_type EQUAL core_type - { $1, $3, make_loc $sloc } -; -constrain_field: - core_type EQUAL core_type - { $1, $3 } -; -(* A group of class descriptions. *) -%inline class_descriptions: - xlist(class_description, and_class_description) - { $1 } -; -%inline class_description: - CLASS - ext = ext - attrs1 = attributes - virt = virtual_flag - params = formal_class_parameters - id = mkrhs(LIDENT) - COLON - cty = class_type - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - ext, - Ci.mk id cty ~virt ~params ~attrs ~loc ~docs - } -; -%inline and_class_description: - AND - attrs1 = attributes - virt = virtual_flag - params = formal_class_parameters - id = mkrhs(LIDENT) - COLON - cty = class_type - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - let text = symbol_text $symbolstartpos in - Ci.mk id cty ~virt ~params ~attrs ~loc ~text ~docs - } -; -class_type_declarations: - xlist(class_type_declaration, and_class_type_declaration) - { $1 } -; -%inline class_type_declaration: - CLASS TYPE - ext = ext - attrs1 = attributes - virt = virtual_flag - params = formal_class_parameters - id = mkrhs(LIDENT) - EQUAL - csig = class_signature - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - ext, - Ci.mk id csig ~virt ~params ~attrs ~loc ~docs - } -; -%inline and_class_type_declaration: - AND - attrs1 = attributes - virt = virtual_flag - params = formal_class_parameters - id = mkrhs(LIDENT) - EQUAL - csig = class_signature - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - let text = symbol_text $symbolstartpos in - Ci.mk id csig ~virt ~params ~attrs ~loc ~text ~docs - } -; - -/* Core expressions */ - -seq_expr: - | expr %prec below_SEMI { $1 } - | expr SEMI { $1 } - | mkexp(expr SEMI seq_expr - { Pexp_sequence($1, $3) }) - { $1 } - | expr SEMI PERCENT attr_id seq_expr - { let seq = mkexp ~loc:$sloc (Pexp_sequence ($1, $5)) in - let payload = PStr [mkstrexp seq []] in - mkexp ~loc:$sloc (Pexp_extension ($4, payload)) } -; -labeled_simple_pattern: - QUESTION LPAREN label_let_pattern opt_default RPAREN - { (Optional (fst $3), $4, snd $3) } - | QUESTION label_var - { (Optional (fst $2), None, snd $2) } - | OPTLABEL LPAREN let_pattern opt_default RPAREN - { (Optional $1, $4, $3) } - | OPTLABEL pattern_var - { (Optional $1, None, $2) } - | TILDE LPAREN label_let_pattern RPAREN - { (Labelled (fst $3), None, snd $3) } - | TILDE label_var - { (Labelled (fst $2), None, snd $2) } - | LABEL simple_pattern - { (Labelled $1, None, $2) } - | simple_pattern - { (Nolabel, None, $1) } -; - -pattern_var: - mkpat( - mkrhs(LIDENT) { Ppat_var $1 } - | UNDERSCORE { Ppat_any } - ) { $1 } -; - -%inline opt_default: - preceded(EQUAL, seq_expr)? - { $1 } -; -label_let_pattern: - x = label_var - { x } - | x = label_var COLON cty = core_type - { let lab, pat = x in - lab, - mkpat ~loc:$sloc (Ppat_constraint (pat, cty)) } -; -%inline label_var: - mkrhs(LIDENT) - { ($1.Location.txt, mkpat ~loc:$sloc (Ppat_var $1)) } -; -let_pattern: - pattern - { $1 } - | mkpat(pattern COLON core_type - { Ppat_constraint($1, $3) }) - { $1 } -; - -%inline indexop_expr(dot, index, right): - | array=simple_expr d=dot LPAREN i=index RPAREN r=right - { array, d, Paren, i, r } - | array=simple_expr d=dot LBRACE i=index RBRACE r=right - { array, d, Brace, i, r } - | array=simple_expr d=dot LBRACKET i=index RBRACKET r=right - { array, d, Bracket, i, r } -; - -%inline indexop_error(dot, index): - | simple_expr dot _p=LPAREN index _e=error - { indexop_unclosed_error $loc(_p) Paren $loc(_e) } - | simple_expr dot _p=LBRACE index _e=error - { indexop_unclosed_error $loc(_p) Brace $loc(_e) } - | simple_expr dot _p=LBRACKET index _e=error - { indexop_unclosed_error $loc(_p) Bracket $loc(_e) } -; - -%inline qualified_dotop: ioption(DOT mod_longident {$2}) DOTOP { $1, $2 }; - -expr: - simple_expr %prec below_HASH - { $1 } - | expr_attrs - { let desc, attrs = $1 in - mkexp_attrs ~loc:$sloc desc attrs } - | mkexp(expr_) - { $1 } - | let_bindings(ext) IN seq_expr - { expr_of_let_bindings ~loc:$sloc $1 $3 } - | pbop_op = mkrhs(LETOP) bindings = letop_bindings IN body = seq_expr - { let (pbop_pat, pbop_exp, rev_ands) = bindings in - let ands = List.rev rev_ands in - let pbop_loc = make_loc $sloc in - let let_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in - mkexp ~loc:$sloc (Pexp_letop{ let_; ands; body}) } - | expr COLONCOLON expr - { mkexp_cons ~loc:$sloc $loc($2) (ghexp ~loc:$sloc (Pexp_tuple[$1;$3])) } - | mkrhs(label) LESSMINUS expr - { mkexp ~loc:$sloc (Pexp_setinstvar($1, $3)) } - | simple_expr DOT mkrhs(label_longident) LESSMINUS expr - { mkexp ~loc:$sloc (Pexp_setfield($1, $3, $5)) } - | indexop_expr(DOT, seq_expr, LESSMINUS v=expr {Some v}) - { mk_indexop_expr builtin_indexing_operators ~loc:$sloc $1 } - | indexop_expr(qualified_dotop, expr_semi_list, LESSMINUS v=expr {Some v}) - { mk_indexop_expr user_indexing_operators ~loc:$sloc $1 } - | expr attribute - { Exp.attr $1 $2 } -/* BEGIN AVOID */ - | UNDERSCORE - { not_expecting $loc($1) "wildcard \"_\"" } -/* END AVOID */ -; -%inline expr_attrs: - | LET MODULE ext_attributes mkrhs(module_name) module_binding_body IN seq_expr - { Pexp_letmodule($4, $5, $7), $3 } - | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr - { Pexp_letexception($4, $6), $3 } - | LET OPEN override_flag ext_attributes module_expr IN seq_expr - { let open_loc = make_loc ($startpos($2), $endpos($5)) in - let od = Opn.mk $5 ~override:$3 ~loc:open_loc in - Pexp_open(od, $7), $4 } - | FUNCTION ext_attributes match_cases - { Pexp_function $3, $2 } - | FUN ext_attributes labeled_simple_pattern fun_def - { let (l,o,p) = $3 in - Pexp_fun(l, o, p, $4), $2 } - | FUN ext_attributes LPAREN TYPE lident_list RPAREN fun_def - { (mk_newtypes ~loc:$sloc $5 $7).pexp_desc, $2 } - | MATCH ext_attributes seq_expr WITH match_cases - { Pexp_match($3, $5), $2 } - | TRY ext_attributes seq_expr WITH match_cases - { Pexp_try($3, $5), $2 } - | TRY ext_attributes seq_expr WITH error - { syntax_error() } - | IF ext_attributes seq_expr THEN expr ELSE expr - { Pexp_ifthenelse($3, $5, Some $7), $2 } - | IF ext_attributes seq_expr THEN expr - { Pexp_ifthenelse($3, $5, None), $2 } - | WHILE ext_attributes seq_expr do_done_expr - { Pexp_while($3, $4), $2 } - | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr - do_done_expr - { Pexp_for($3, $5, $7, $6, $8), $2 } - | ASSERT ext_attributes simple_expr %prec below_HASH - { Pexp_assert $3, $2 } - | LAZY ext_attributes simple_expr %prec below_HASH - { Pexp_lazy $3, $2 } -; -%inline do_done_expr: - | DO e = seq_expr DONE - { e } - | DO seq_expr error - { unclosed "do" $loc($1) "done" $loc($2) } -; -%inline expr_: - | simple_expr nonempty_llist(labeled_simple_expr) - { Pexp_apply($1, $2) } - | expr_comma_list %prec below_COMMA - { Pexp_tuple($1) } - | mkrhs(constr_longident) simple_expr %prec below_HASH - { Pexp_construct($1, Some $2) } - | name_tag simple_expr %prec below_HASH - { Pexp_variant($1, Some $2) } - | e1 = expr op = op(infix_operator) e2 = expr - { mkinfix e1 op e2 } - | subtractive expr %prec prec_unary_minus - { mkuminus ~oploc:$loc($1) $1 $2 } - | additive expr %prec prec_unary_plus - { mkuplus ~oploc:$loc($1) $1 $2 } -; - -simple_expr: - | LPAREN seq_expr RPAREN - { reloc_exp ~loc:$sloc $2 } - | LPAREN seq_expr error - { unclosed "(" $loc($1) ")" $loc($3) } - | LPAREN seq_expr type_constraint RPAREN - { mkexp_constraint ~loc:$sloc $2 $3 } - | indexop_expr(DOT, seq_expr, { None }) - { mk_indexop_expr builtin_indexing_operators ~loc:$sloc $1 } - | indexop_expr(qualified_dotop, expr_semi_list, { None }) - { mk_indexop_expr user_indexing_operators ~loc:$sloc $1 } - | indexop_error (DOT, seq_expr) { $1 } - | indexop_error (qualified_dotop, expr_semi_list) { $1 } - | simple_expr_attrs - { let desc, attrs = $1 in - mkexp_attrs ~loc:$sloc desc attrs } - | mkexp(simple_expr_) - { $1 } -; -%inline simple_expr_attrs: - | BEGIN ext = ext attrs = attributes e = seq_expr END - { e.pexp_desc, (ext, attrs @ e.pexp_attributes) } - | BEGIN ext_attributes END - { Pexp_construct (mkloc (Lident "()") (make_loc $sloc), None), $2 } - | BEGIN ext_attributes seq_expr error - { unclosed "begin" $loc($1) "end" $loc($4) } - | NEW ext_attributes mkrhs(class_longident) - { Pexp_new($3), $2 } - | LPAREN MODULE ext_attributes module_expr RPAREN - { Pexp_pack $4, $3 } - | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN - { Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $4), $6), $3 } - | LPAREN MODULE ext_attributes module_expr COLON error - { unclosed "(" $loc($1) ")" $loc($6) } - | OBJECT ext_attributes class_structure END - { Pexp_object $3, $2 } - | OBJECT ext_attributes class_structure error - { unclosed "object" $loc($1) "end" $loc($4) } -; -%inline simple_expr_: - | mkrhs(val_longident) - { Pexp_ident ($1) } - | constant - { Pexp_constant $1 } - | mkrhs(constr_longident) %prec prec_constant_constructor - { Pexp_construct($1, None) } - | name_tag %prec prec_constant_constructor - { Pexp_variant($1, None) } - | op(PREFIXOP) simple_expr - { Pexp_apply($1, [Nolabel,$2]) } - | op(BANG {"!"}) simple_expr - { Pexp_apply($1, [Nolabel,$2]) } - | LBRACELESS object_expr_content GREATERRBRACE - { Pexp_override $2 } - | LBRACELESS object_expr_content error - { unclosed "{<" $loc($1) ">}" $loc($3) } - | LBRACELESS GREATERRBRACE - { Pexp_override [] } - | simple_expr DOT mkrhs(label_longident) - { Pexp_field($1, $3) } - | od=open_dot_declaration DOT LPAREN seq_expr RPAREN - { Pexp_open(od, $4) } - | od=open_dot_declaration DOT LBRACELESS object_expr_content GREATERRBRACE - { (* TODO: review the location of Pexp_override *) - Pexp_open(od, mkexp ~loc:$sloc (Pexp_override $4)) } - | mod_longident DOT LBRACELESS object_expr_content error - { unclosed "{<" $loc($3) ">}" $loc($5) } - | simple_expr HASH mkrhs(label) - { Pexp_send($1, $3) } - | simple_expr op(HASHOP) simple_expr - { mkinfix $1 $2 $3 } - | extension - { Pexp_extension $1 } - | od=open_dot_declaration DOT mkrhs(LPAREN RPAREN {Lident "()"}) - { Pexp_open(od, mkexp ~loc:($loc($3)) (Pexp_construct($3, None))) } - | mod_longident DOT LPAREN seq_expr error - { unclosed "(" $loc($3) ")" $loc($5) } - | LBRACE record_expr_content RBRACE - { let (exten, fields) = $2 in - Pexp_record(fields, exten) } - | LBRACE record_expr_content error - { unclosed "{" $loc($1) "}" $loc($3) } - | od=open_dot_declaration DOT LBRACE record_expr_content RBRACE - { let (exten, fields) = $4 in - Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) - (Pexp_record(fields, exten))) } - | mod_longident DOT LBRACE record_expr_content error - { unclosed "{" $loc($3) "}" $loc($5) } - | LBRACKETBAR expr_semi_list BARRBRACKET - { Pexp_array($2) } - | LBRACKETBAR expr_semi_list error - { unclosed "[|" $loc($1) "|]" $loc($3) } - | LBRACKETBAR BARRBRACKET - { Pexp_array [] } - | od=open_dot_declaration DOT LBRACKETBAR expr_semi_list BARRBRACKET - { Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) (Pexp_array($4))) } - | od=open_dot_declaration DOT LBRACKETBAR BARRBRACKET - { (* TODO: review the location of Pexp_array *) - Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) (Pexp_array [])) } - | mod_longident DOT - LBRACKETBAR expr_semi_list error - { unclosed "[|" $loc($3) "|]" $loc($5) } - | LBRACKET expr_semi_list RBRACKET - { fst (mktailexp $loc($3) $2) } - | LBRACKET expr_semi_list error - { unclosed "[" $loc($1) "]" $loc($3) } - | od=open_dot_declaration DOT LBRACKET expr_semi_list RBRACKET - { let list_exp = - (* TODO: review the location of list_exp *) - let tail_exp, _tail_loc = mktailexp $loc($5) $4 in - mkexp ~loc:($startpos($3), $endpos) tail_exp in - Pexp_open(od, list_exp) } - | od=open_dot_declaration DOT mkrhs(LBRACKET RBRACKET {Lident "[]"}) - { Pexp_open(od, mkexp ~loc:$loc($3) (Pexp_construct($3, None))) } - | mod_longident DOT - LBRACKET expr_semi_list error - { unclosed "[" $loc($3) "]" $loc($5) } - | od=open_dot_declaration DOT LPAREN MODULE ext_attributes module_expr COLON - package_type RPAREN - { let modexp = - mkexp_attrs ~loc:($startpos($3), $endpos) - (Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $6), $8)) $5 in - Pexp_open(od, modexp) } - | mod_longident DOT - LPAREN MODULE ext_attributes module_expr COLON error - { unclosed "(" $loc($3) ")" $loc($8) } -; -labeled_simple_expr: - simple_expr %prec below_HASH - { (Nolabel, $1) } - | LABEL simple_expr %prec below_HASH - { (Labelled $1, $2) } - | TILDE label = LIDENT - { let loc = $loc(label) in - (Labelled label, mkexpvar ~loc label) } - | TILDE LPAREN label = LIDENT ty = type_constraint RPAREN - { (Labelled label, mkexp_constraint ~loc:($startpos($2), $endpos) - (mkexpvar ~loc:$loc(label) label) ty) } - | QUESTION label = LIDENT - { let loc = $loc(label) in - (Optional label, mkexpvar ~loc label) } - | OPTLABEL simple_expr %prec below_HASH - { (Optional $1, $2) } -; -%inline lident_list: - xs = mkrhs(LIDENT)+ - { xs } -; -%inline let_ident: - val_ident { mkpatvar ~loc:$sloc $1 } -; -let_binding_body_no_punning: - let_ident strict_binding - { ($1, $2, None) } - | let_ident type_constraint EQUAL seq_expr - { let v = $1 in (* PR#7344 *) - let t = - match $2 with - Some t, None -> - Pvc_constraint { locally_abstract_univars = []; typ=t } - | ground, Some coercion -> Pvc_coercion { ground; coercion} - | _ -> assert false - in - (v, $4, Some t) - } - | let_ident COLON poly(core_type) EQUAL seq_expr - { - let t = ghtyp ~loc:($loc($3)) $3 in - ($1, $5, Some (Pvc_constraint { locally_abstract_univars = []; typ=t })) - } - | let_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr - { let constraint' = - Pvc_constraint { locally_abstract_univars=$4; typ = $6} - in - ($1, $8, Some constraint') } - | pattern_no_exn EQUAL seq_expr - { ($1, $3, None) } - | simple_pattern_not_ident COLON core_type EQUAL seq_expr - { ($1, $5, Some(Pvc_constraint { locally_abstract_univars=[]; typ=$3 })) } -; -let_binding_body: - | let_binding_body_no_punning - { let p,e,c = $1 in (p,e,c,false) } -/* BEGIN AVOID */ - | val_ident %prec below_HASH - { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1, None, true) } - (* The production that allows puns is marked so that [make list-parse-errors] - does not attempt to exploit it. That would be problematic because it - would then generate bindings such as [let x], which are rejected by the - auxiliary function [addlb] via a call to [syntax_error]. *) -/* END AVOID */ -; -(* The formal parameter EXT can be instantiated with ext or no_ext - so as to indicate whether an extension is allowed or disallowed. *) -let_bindings(EXT): - let_binding(EXT) { $1 } - | let_bindings(EXT) and_let_binding { addlb $1 $2 } -; -%inline let_binding(EXT): - LET - ext = EXT - attrs1 = attributes - rec_flag = rec_flag - body = let_binding_body - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - mklbs ext rec_flag (mklb ~loc:$sloc true body attrs) - } -; -and_let_binding: - AND - attrs1 = attributes - body = let_binding_body - attrs2 = post_item_attributes - { - let attrs = attrs1 @ attrs2 in - mklb ~loc:$sloc false body attrs - } -; -letop_binding_body: - pat = let_ident exp = strict_binding - { (pat, exp) } - | val_ident - (* Let-punning *) - { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1) } - | pat = simple_pattern COLON typ = core_type EQUAL exp = seq_expr - { let loc = ($startpos(pat), $endpos(typ)) in - (ghpat ~loc (Ppat_constraint(pat, typ)), exp) } - | pat = pattern_no_exn EQUAL exp = seq_expr - { (pat, exp) } -; -letop_bindings: - body = letop_binding_body - { let let_pat, let_exp = body in - let_pat, let_exp, [] } - | bindings = letop_bindings pbop_op = mkrhs(ANDOP) body = letop_binding_body - { let let_pat, let_exp, rev_ands = bindings in - let pbop_pat, pbop_exp = body in - let pbop_loc = make_loc $sloc in - let and_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in - let_pat, let_exp, and_ :: rev_ands } -; -fun_binding: - strict_binding - { $1 } - | type_constraint EQUAL seq_expr - { mkexp_constraint ~loc:$sloc $3 $1 } -; -strict_binding: - EQUAL seq_expr - { $2 } - | labeled_simple_pattern fun_binding - { let (l, o, p) = $1 in ghexp ~loc:$sloc (Pexp_fun(l, o, p, $2)) } - | LPAREN TYPE lident_list RPAREN fun_binding - { mk_newtypes ~loc:$sloc $3 $5 } -; -%inline match_cases: - xs = preceded_or_separated_nonempty_llist(BAR, match_case) - { xs } -; -match_case: - pattern MINUSGREATER seq_expr - { Exp.case $1 $3 } - | pattern WHEN seq_expr MINUSGREATER seq_expr - { Exp.case $1 ~guard:$3 $5 } - | pattern MINUSGREATER DOT - { Exp.case $1 (Exp.unreachable ~loc:(make_loc $loc($3)) ()) } -; -fun_def: - MINUSGREATER seq_expr - { $2 } - | mkexp(COLON atomic_type MINUSGREATER seq_expr - { Pexp_constraint ($4, $2) }) - { $1 } -/* Cf #5939: we used to accept (fun p when e0 -> e) */ - | labeled_simple_pattern fun_def - { - let (l,o,p) = $1 in - ghexp ~loc:$sloc (Pexp_fun(l, o, p, $2)) - } - | LPAREN TYPE lident_list RPAREN fun_def - { mk_newtypes ~loc:$sloc $3 $5 } -; -%inline expr_comma_list: - es = separated_nontrivial_llist(COMMA, expr) - { es } -; -record_expr_content: - eo = ioption(terminated(simple_expr, WITH)) - fields = separated_or_terminated_nonempty_list(SEMI, record_expr_field) - { eo, fields } -; -%inline record_expr_field: - | label = mkrhs(label_longident) - c = type_constraint? - eo = preceded(EQUAL, expr)? - { let constraint_loc, label, e = - match eo with - | None -> - (* No pattern; this is a pun. Desugar it. *) - $sloc, make_ghost label, exp_of_longident label - | Some e -> - ($startpos(c), $endpos), label, e - in - label, mkexp_opt_constraint ~loc:constraint_loc e c } -; -%inline object_expr_content: - xs = separated_or_terminated_nonempty_list(SEMI, object_expr_field) - { xs } -; -%inline object_expr_field: - label = mkrhs(label) - oe = preceded(EQUAL, expr)? - { let label, e = - match oe with - | None -> - (* No expression; this is a pun. Desugar it. *) - make_ghost label, exp_of_label label - | Some e -> - label, e - in - label, e } -; -%inline expr_semi_list: - es = separated_or_terminated_nonempty_list(SEMI, expr) - { es } -; -type_constraint: - COLON core_type { (Some $2, None) } - | COLON core_type COLONGREATER core_type { (Some $2, Some $4) } - | COLONGREATER core_type { (None, Some $2) } - | COLON error { syntax_error() } - | COLONGREATER error { syntax_error() } -; - -/* Patterns */ - -(* Whereas [pattern] is an arbitrary pattern, [pattern_no_exn] is a pattern - that does not begin with the [EXCEPTION] keyword. Thus, [pattern_no_exn] - is the intersection of the context-free language [pattern] with the - regular language [^EXCEPTION .*]. - - Ideally, we would like to use [pattern] everywhere and check in a later - phase that EXCEPTION patterns are used only where they are allowed (there - is code in typing/typecore.ml to this end). Unfortunately, in the - definition of [let_binding_body], we cannot allow [pattern]. That would - create a shift/reduce conflict: upon seeing LET EXCEPTION ..., the parser - wouldn't know whether this is the beginning of a LET EXCEPTION construct or - the beginning of a LET construct whose pattern happens to begin with - EXCEPTION. The conflict is avoided there by using [pattern_no_exn] in the - definition of [let_binding_body]. - - In order to avoid duplication between the definitions of [pattern] and - [pattern_no_exn], we create a parameterized definition [pattern_(self)] - and instantiate it twice. *) - -pattern: - pattern_(pattern) - { $1 } - | EXCEPTION ext_attributes pattern %prec prec_constr_appl - { mkpat_attrs ~loc:$sloc (Ppat_exception $3) $2} -; - -pattern_no_exn: - pattern_(pattern_no_exn) - { $1 } -; - -%inline pattern_(self): - | self COLONCOLON pattern - { mkpat_cons ~loc:$sloc $loc($2) (ghpat ~loc:$sloc (Ppat_tuple[$1;$3])) } - | self attribute - { Pat.attr $1 $2 } - | pattern_gen - { $1 } - | mkpat( - self AS mkrhs(val_ident) - { Ppat_alias($1, $3) } - | self AS error - { expecting $loc($3) "identifier" } - | pattern_comma_list(self) %prec below_COMMA - { Ppat_tuple(List.rev $1) } - | self COLONCOLON error - { expecting $loc($3) "pattern" } - | self BAR pattern - { Ppat_or($1, $3) } - | self BAR error - { expecting $loc($3) "pattern" } - ) { $1 } -; - -pattern_gen: - simple_pattern - { $1 } - | mkpat( - mkrhs(constr_longident) pattern %prec prec_constr_appl - { Ppat_construct($1, Some ([], $2)) } - | constr=mkrhs(constr_longident) LPAREN TYPE newtypes=lident_list RPAREN - pat=simple_pattern - { Ppat_construct(constr, Some (newtypes, pat)) } - | name_tag pattern %prec prec_constr_appl - { Ppat_variant($1, Some $2) } - ) { $1 } - | LAZY ext_attributes simple_pattern - { mkpat_attrs ~loc:$sloc (Ppat_lazy $3) $2} -; -simple_pattern: - mkpat(mkrhs(val_ident) %prec below_EQUAL - { Ppat_var ($1) }) - { $1 } - | simple_pattern_not_ident { $1 } -; - -simple_pattern_not_ident: - | LPAREN pattern RPAREN - { reloc_pat ~loc:$sloc $2 } - | simple_delimited_pattern - { $1 } - | LPAREN MODULE ext_attributes mkrhs(module_name) RPAREN - { mkpat_attrs ~loc:$sloc (Ppat_unpack $4) $3 } - | LPAREN MODULE ext_attributes mkrhs(module_name) COLON package_type RPAREN - { mkpat_attrs ~loc:$sloc - (Ppat_constraint(mkpat ~loc:$loc($4) (Ppat_unpack $4), $6)) - $3 } - | mkpat(simple_pattern_not_ident_) - { $1 } -; -%inline simple_pattern_not_ident_: - | UNDERSCORE - { Ppat_any } - | signed_constant - { Ppat_constant $1 } - | signed_constant DOTDOT signed_constant - { Ppat_interval ($1, $3) } - | mkrhs(constr_longident) - { Ppat_construct($1, None) } - | name_tag - { Ppat_variant($1, None) } - | HASH mkrhs(type_longident) - { Ppat_type ($2) } - | mkrhs(mod_longident) DOT simple_delimited_pattern - { Ppat_open($1, $3) } - | mkrhs(mod_longident) DOT mkrhs(LBRACKET RBRACKET {Lident "[]"}) - { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) } - | mkrhs(mod_longident) DOT mkrhs(LPAREN RPAREN {Lident "()"}) - { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) } - | mkrhs(mod_longident) DOT LPAREN pattern RPAREN - { Ppat_open ($1, $4) } - | mod_longident DOT LPAREN pattern error - { unclosed "(" $loc($3) ")" $loc($5) } - | mod_longident DOT LPAREN error - { expecting $loc($4) "pattern" } - | LPAREN pattern error - { unclosed "(" $loc($1) ")" $loc($3) } - | LPAREN pattern COLON core_type RPAREN - { Ppat_constraint($2, $4) } - | LPAREN pattern COLON core_type error - { unclosed "(" $loc($1) ")" $loc($5) } - | LPAREN pattern COLON error - { expecting $loc($4) "type" } - | LPAREN MODULE ext_attributes module_name COLON package_type - error - { unclosed "(" $loc($1) ")" $loc($7) } - | extension - { Ppat_extension $1 } -; - -simple_delimited_pattern: - mkpat( - LBRACE record_pat_content RBRACE - { let (fields, closed) = $2 in - Ppat_record(fields, closed) } - | LBRACE record_pat_content error - { unclosed "{" $loc($1) "}" $loc($3) } - | LBRACKET pattern_semi_list RBRACKET - { fst (mktailpat $loc($3) $2) } - | LBRACKET pattern_semi_list error - { unclosed "[" $loc($1) "]" $loc($3) } - | LBRACKETBAR pattern_semi_list BARRBRACKET - { Ppat_array $2 } - | LBRACKETBAR BARRBRACKET - { Ppat_array [] } - | LBRACKETBAR pattern_semi_list error - { unclosed "[|" $loc($1) "|]" $loc($3) } - ) { $1 } - -pattern_comma_list(self): - pattern_comma_list(self) COMMA pattern { $3 :: $1 } - | self COMMA pattern { [$3; $1] } - | self COMMA error { expecting $loc($3) "pattern" } -; -%inline pattern_semi_list: - ps = separated_or_terminated_nonempty_list(SEMI, pattern) - { ps } -; -(* A label-pattern list is a nonempty list of label-pattern pairs, optionally - followed with an UNDERSCORE, separated-or-terminated with semicolons. *) -%inline record_pat_content: - listx(SEMI, record_pat_field, UNDERSCORE) - { let fields, closed = $1 in - let closed = match closed with Some () -> Open | None -> Closed in - fields, closed } -; -%inline record_pat_field: - label = mkrhs(label_longident) - octy = preceded(COLON, core_type)? - opat = preceded(EQUAL, pattern)? - { let constraint_loc, label, pat = - match opat with - | None -> - (* No pattern; this is a pun. Desugar it. - But that the pattern was there and the label reconstructed (which - piece of AST is marked as ghost is important for warning - emission). *) - $sloc, make_ghost label, pat_of_label label - | Some pat -> - ($startpos(octy), $endpos), label, pat - in - label, mkpat_opt_constraint ~loc:constraint_loc pat octy - } -; - -/* Value descriptions */ - -value_description: - VAL - ext = ext - attrs1 = attributes - id = mkrhs(val_ident) - COLON - ty = possibly_poly(core_type) - attrs2 = post_item_attributes - { let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - Val.mk id ty ~attrs ~loc ~docs, - ext } -; - -/* Primitive declarations */ - -primitive_declaration: - EXTERNAL - ext = ext - attrs1 = attributes - id = mkrhs(val_ident) - COLON - ty = possibly_poly(core_type) - EQUAL - prim = raw_string+ - attrs2 = post_item_attributes - { let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - Val.mk id ty ~prim ~attrs ~loc ~docs, - ext } -; - -(* Type declarations and type substitutions. *) - -(* Type declarations [type t = u] and type substitutions [type t := u] are very - similar, so we view them as instances of [generic_type_declarations]. In the - case of a type declaration, the use of [nonrec_flag] means that [NONREC] may - be absent or present, whereas in the case of a type substitution, the use of - [no_nonrec_flag] means that [NONREC] must be absent. The use of [type_kind] - versus [type_subst_kind] means that in the first case, we expect an [EQUAL] - sign, whereas in the second case, we expect [COLONEQUAL]. *) - -%inline type_declarations: - generic_type_declarations(nonrec_flag, type_kind) - { $1 } -; - -%inline type_subst_declarations: - generic_type_declarations(no_nonrec_flag, type_subst_kind) - { $1 } -; - -(* A set of type declarations or substitutions begins with a - [generic_type_declaration] and continues with a possibly empty list of - [generic_and_type_declaration]s. *) - -%inline generic_type_declarations(flag, kind): - xlist( - generic_type_declaration(flag, kind), - generic_and_type_declaration(kind) - ) - { $1 } -; - -(* [generic_type_declaration] and [generic_and_type_declaration] look similar, - but are in reality different enough that it is difficult to share anything - between them. *) - -generic_type_declaration(flag, kind): - TYPE - ext = ext - attrs1 = attributes - flag = flag - params = type_parameters - id = mkrhs(LIDENT) - kind_priv_manifest = kind - cstrs = constraints - attrs2 = post_item_attributes - { - let (kind, priv, manifest) = kind_priv_manifest in - let docs = symbol_docs $sloc in - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - (flag, ext), - Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs - } -; -%inline generic_and_type_declaration(kind): - AND - attrs1 = attributes - params = type_parameters - id = mkrhs(LIDENT) - kind_priv_manifest = kind - cstrs = constraints - attrs2 = post_item_attributes - { - let (kind, priv, manifest) = kind_priv_manifest in - let docs = symbol_docs $sloc in - let attrs = attrs1 @ attrs2 in - let loc = make_loc $sloc in - let text = symbol_text $symbolstartpos in - Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text - } -; -%inline constraints: - llist(preceded(CONSTRAINT, constrain)) - { $1 } -; -(* Lots of %inline expansion are required for [nonempty_type_kind] to be - LR(1). At the cost of some manual expansion, it would be possible to give a - definition that leads to a smaller grammar (after expansion) and therefore - a smaller automaton. *) -nonempty_type_kind: - | priv = inline_private_flag - ty = core_type - { (Ptype_abstract, priv, Some ty) } - | oty = type_synonym - priv = inline_private_flag - cs = constructor_declarations - { (Ptype_variant cs, priv, oty) } - | oty = type_synonym - priv = inline_private_flag - DOTDOT - { (Ptype_open, priv, oty) } - | oty = type_synonym - priv = inline_private_flag - LBRACE ls = label_declarations RBRACE - { (Ptype_record ls, priv, oty) } -; -%inline type_synonym: - ioption(terminated(core_type, EQUAL)) - { $1 } -; -type_kind: - /*empty*/ - { (Ptype_abstract, Public, None) } - | EQUAL nonempty_type_kind - { $2 } -; -%inline type_subst_kind: - COLONEQUAL nonempty_type_kind - { $2 } -; -type_parameters: - /* empty */ - { [] } - | p = type_parameter - { [p] } - | LPAREN ps = separated_nonempty_llist(COMMA, type_parameter) RPAREN - { ps } -; -type_parameter: - type_variance type_variable { $2, $1 } -; -type_variable: - mktyp( - QUOTE tyvar = ident - { Ptyp_var tyvar } - | UNDERSCORE - { Ptyp_any } - ) { $1 } -; - -type_variance: - /* empty */ { NoVariance, NoInjectivity } - | PLUS { Covariant, NoInjectivity } - | MINUS { Contravariant, NoInjectivity } - | BANG { NoVariance, Injective } - | PLUS BANG | BANG PLUS { Covariant, Injective } - | MINUS BANG | BANG MINUS { Contravariant, Injective } - | INFIXOP2 - { if $1 = "+!" then Covariant, Injective else - if $1 = "-!" then Contravariant, Injective else - expecting $loc($1) "type_variance" } - | PREFIXOP - { if $1 = "!+" then Covariant, Injective else - if $1 = "!-" then Contravariant, Injective else - expecting $loc($1) "type_variance" } -; - -(* A sequence of constructor declarations is either a single BAR, which - means that the list is empty, or a nonempty BAR-separated list of - declarations, with an optional leading BAR. *) -constructor_declarations: - | BAR - { [] } - | cs = bar_llist(constructor_declaration) - { cs } -; -(* A constructor declaration begins with an opening symbol, which can - be either epsilon or BAR. Note that this opening symbol is included - in the footprint $sloc. *) -(* Because [constructor_declaration] and [extension_constructor_declaration] - are identical except for their semantic actions, we introduce the symbol - [generic_constructor_declaration], whose semantic action is neutral -- it - merely returns a tuple. *) -generic_constructor_declaration(opening): - opening - cid = mkrhs(constr_ident) - vars_args_res = generalized_constructor_arguments - attrs = attributes - { - let vars, args, res = vars_args_res in - let info = symbol_info $endpos in - let loc = make_loc $sloc in - cid, vars, args, res, attrs, loc, info - } -; -%inline constructor_declaration(opening): - d = generic_constructor_declaration(opening) - { - let cid, vars, args, res, attrs, loc, info = d in - Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info - } -; -str_exception_declaration: - sig_exception_declaration - { $1 } -| EXCEPTION - ext = ext - attrs1 = attributes - id = mkrhs(constr_ident) - EQUAL - lid = mkrhs(constr_longident) - attrs2 = attributes - attrs = post_item_attributes - { let loc = make_loc $sloc in - let docs = symbol_docs $sloc in - Te.mk_exception ~attrs - (Te.rebind id lid ~attrs:(attrs1 @ attrs2) ~loc ~docs) - , ext } -; -sig_exception_declaration: - EXCEPTION - ext = ext - attrs1 = attributes - id = mkrhs(constr_ident) - vars_args_res = generalized_constructor_arguments - attrs2 = attributes - attrs = post_item_attributes - { let vars, args, res = vars_args_res in - let loc = make_loc ($startpos, $endpos(attrs2)) in - let docs = symbol_docs $sloc in - Te.mk_exception ~attrs - (Te.decl id ~vars ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs) - , ext } -; -%inline let_exception_declaration: - mkrhs(constr_ident) generalized_constructor_arguments attributes - { let vars, args, res = $2 in - Te.decl $1 ~vars ~args ?res ~attrs:$3 ~loc:(make_loc $sloc) } -; -generalized_constructor_arguments: - /*empty*/ { ([],Pcstr_tuple [],None) } - | OF constructor_arguments { ([],$2,None) } - | COLON constructor_arguments MINUSGREATER atomic_type %prec below_HASH - { ([],$2,Some $4) } - | COLON typevar_list DOT constructor_arguments MINUSGREATER atomic_type - %prec below_HASH - { ($2,$4,Some $6) } - | COLON atomic_type %prec below_HASH - { ([],Pcstr_tuple [],Some $2) } - | COLON typevar_list DOT atomic_type %prec below_HASH - { ($2,Pcstr_tuple [],Some $4) } -; - -constructor_arguments: - | tys = inline_separated_nonempty_llist(STAR, atomic_type) - %prec below_HASH - { Pcstr_tuple tys } - | LBRACE label_declarations RBRACE - { Pcstr_record $2 } -; -label_declarations: - label_declaration { [$1] } - | label_declaration_semi { [$1] } - | label_declaration_semi label_declarations { $1 :: $2 } -; -label_declaration: - mutable_flag mkrhs(label) COLON poly_type_no_attr attributes - { let info = symbol_info $endpos in - Type.field $2 $4 ~mut:$1 ~attrs:$5 ~loc:(make_loc $sloc) ~info } -; -label_declaration_semi: - mutable_flag mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes - { let info = - match rhs_info $endpos($5) with - | Some _ as info_before_semi -> info_before_semi - | None -> symbol_info $endpos - in - Type.field $2 $4 ~mut:$1 ~attrs:($5 @ $7) ~loc:(make_loc $sloc) ~info } -; - -/* Type Extensions */ - -%inline str_type_extension: - type_extension(extension_constructor) - { $1 } -; -%inline sig_type_extension: - type_extension(extension_constructor_declaration) - { $1 } -; -%inline type_extension(declaration): - TYPE - ext = ext - attrs1 = attributes - no_nonrec_flag - params = type_parameters - tid = mkrhs(type_longident) - PLUSEQ - priv = private_flag - cs = bar_llist(declaration) - attrs2 = post_item_attributes - { let docs = symbol_docs $sloc in - let attrs = attrs1 @ attrs2 in - Te.mk tid cs ~params ~priv ~attrs ~docs, - ext } -; -%inline extension_constructor(opening): - extension_constructor_declaration(opening) - { $1 } - | extension_constructor_rebind(opening) - { $1 } -; -%inline extension_constructor_declaration(opening): - d = generic_constructor_declaration(opening) - { - let cid, vars, args, res, attrs, loc, info = d in - Te.decl cid ~vars ~args ?res ~attrs ~loc ~info - } -; -extension_constructor_rebind(opening): - opening - cid = mkrhs(constr_ident) - EQUAL - lid = mkrhs(constr_longident) - attrs = attributes - { let info = symbol_info $endpos in - Te.rebind cid lid ~attrs ~loc:(make_loc $sloc) ~info } -; - -/* "with" constraints (additional type equations over signature components) */ - -with_constraint: - TYPE type_parameters mkrhs(label_longident) with_type_binder - core_type_no_attr constraints - { let lident = loc_last $3 in - Pwith_type - ($3, - (Type.mk lident - ~params:$2 - ~cstrs:$6 - ~manifest:$5 - ~priv:$4 - ~loc:(make_loc $sloc))) } - /* used label_longident instead of type_longident to disallow - functor applications in type path */ - | TYPE type_parameters mkrhs(label_longident) - COLONEQUAL core_type_no_attr - { let lident = loc_last $3 in - Pwith_typesubst - ($3, - (Type.mk lident - ~params:$2 - ~manifest:$5 - ~loc:(make_loc $sloc))) } - | MODULE mkrhs(mod_longident) EQUAL mkrhs(mod_ext_longident) - { Pwith_module ($2, $4) } - | MODULE mkrhs(mod_longident) COLONEQUAL mkrhs(mod_ext_longident) - { Pwith_modsubst ($2, $4) } - | MODULE TYPE l=mkrhs(mty_longident) EQUAL rhs=module_type - { Pwith_modtype (l, rhs) } - | MODULE TYPE l=mkrhs(mty_longident) COLONEQUAL rhs=module_type - { Pwith_modtypesubst (l, rhs) } -; -with_type_binder: - EQUAL { Public } - | EQUAL PRIVATE { Private } -; - -/* Polymorphic types */ - -%inline typevar: - QUOTE mkrhs(ident) - { $2 } -; -%inline typevar_list: - nonempty_llist(typevar) - { $1 } -; -%inline poly(X): - typevar_list DOT X - { Ptyp_poly($1, $3) } -; -possibly_poly(X): - X - { $1 } -| mktyp(poly(X)) - { $1 } -; -%inline poly_type: - possibly_poly(core_type) - { $1 } -; -%inline poly_type_no_attr: - possibly_poly(core_type_no_attr) - { $1 } -; - -(* -------------------------------------------------------------------------- *) - -(* Core language types. *) - -(* A core type (core_type) is a core type without attributes (core_type_no_attr) - followed with a list of attributes. *) -core_type: - core_type_no_attr - { $1 } - | core_type attribute - { Typ.attr $1 $2 } -; - -(* A core type without attributes is currently defined as an alias type, but - this could change in the future if new forms of types are introduced. From - the outside, one should use core_type_no_attr. *) -%inline core_type_no_attr: - alias_type - { $1 } -; - -(* Alias types include: - - function types (see below); - - proper alias types: 'a -> int as 'a - *) -alias_type: - function_type - { $1 } - | mktyp( - ty = alias_type AS QUOTE tyvar = ident - { Ptyp_alias(ty, tyvar) } - ) - { $1 } -; - -(* Function types include: - - tuple types (see below); - - proper function types: int -> int - foo: int -> int - ?foo: int -> int - *) -function_type: - | ty = tuple_type - %prec MINUSGREATER - { ty } - | mktyp( - label = arg_label - domain = extra_rhs(tuple_type) - MINUSGREATER - codomain = function_type - { Ptyp_arrow(label, domain, codomain) } - ) - { $1 } -; -%inline arg_label: - | label = optlabel - { Optional label } - | label = LIDENT COLON - { Labelled label } - | /* empty */ - { Nolabel } -; -(* Tuple types include: - - atomic types (see below); - - proper tuple types: int * int * int list - A proper tuple type is a star-separated list of at least two atomic types. - *) -tuple_type: - | ty = atomic_type - %prec below_HASH - { ty } - | mktyp( - tys = separated_nontrivial_llist(STAR, atomic_type) - { Ptyp_tuple tys } - ) - { $1 } -; - -(* Atomic types are the most basic level in the syntax of types. - Atomic types include: - - types between parentheses: (int -> int) - - first-class module types: (module S) - - type variables: 'a - - applications of type constructors: int, int list, int option list - - variant types: [`A] - *) -atomic_type: - | LPAREN core_type RPAREN - { $2 } - | LPAREN MODULE ext_attributes package_type RPAREN - { wrap_typ_attrs ~loc:$sloc (reloc_typ ~loc:$sloc $4) $3 } - | mktyp( /* begin mktyp group */ - QUOTE ident - { Ptyp_var $2 } - | UNDERSCORE - { Ptyp_any } - | tys = actual_type_parameters - tid = mkrhs(type_longident) - { Ptyp_constr(tid, tys) } - | LESS meth_list GREATER - { let (f, c) = $2 in Ptyp_object (f, c) } - | LESS GREATER - { Ptyp_object ([], Closed) } - | tys = actual_type_parameters - HASH - cid = mkrhs(clty_longident) - { Ptyp_class(cid, tys) } - | LBRACKET tag_field RBRACKET - (* not row_field; see CONFLICTS *) - { Ptyp_variant([$2], Closed, None) } - | LBRACKET BAR row_field_list RBRACKET - { Ptyp_variant($3, Closed, None) } - | LBRACKET row_field BAR row_field_list RBRACKET - { Ptyp_variant($2 :: $4, Closed, None) } - | LBRACKETGREATER BAR? row_field_list RBRACKET - { Ptyp_variant($3, Open, None) } - | LBRACKETGREATER RBRACKET - { Ptyp_variant([], Open, None) } - | LBRACKETLESS BAR? row_field_list RBRACKET - { Ptyp_variant($3, Closed, Some []) } - | LBRACKETLESS BAR? row_field_list GREATER name_tag_list RBRACKET - { Ptyp_variant($3, Closed, Some $5) } - | extension - { Ptyp_extension $1 } - ) - { $1 } /* end mktyp group */ -; - -(* This is the syntax of the actual type parameters in an application of - a type constructor, such as int, int list, or (int, bool) Hashtbl.t. - We allow one of the following: - - zero parameters; - - one parameter: - an atomic type; - among other things, this can be an arbitrary type between parentheses; - - two or more parameters: - arbitrary types, between parentheses, separated with commas. - *) -%inline actual_type_parameters: - | /* empty */ - { [] } - | ty = atomic_type - { [ty] } - | LPAREN tys = separated_nontrivial_llist(COMMA, core_type) RPAREN - { tys } -; - -%inline package_type: module_type - { let (lid, cstrs, attrs) = package_type_of_module_type $1 in - let descr = Ptyp_package (lid, cstrs) in - mktyp ~loc:$sloc ~attrs descr } -; -%inline row_field_list: - separated_nonempty_llist(BAR, row_field) - { $1 } -; -row_field: - tag_field - { $1 } - | core_type - { Rf.inherit_ ~loc:(make_loc $sloc) $1 } -; -tag_field: - mkrhs(name_tag) OF opt_ampersand amper_type_list attributes - { let info = symbol_info $endpos in - let attrs = add_info_attrs info $5 in - Rf.tag ~loc:(make_loc $sloc) ~attrs $1 $3 $4 } - | mkrhs(name_tag) attributes - { let info = symbol_info $endpos in - let attrs = add_info_attrs info $2 in - Rf.tag ~loc:(make_loc $sloc) ~attrs $1 true [] } -; -opt_ampersand: - AMPERSAND { true } - | /* empty */ { false } -; -%inline amper_type_list: - separated_nonempty_llist(AMPERSAND, core_type_no_attr) - { $1 } -; -%inline name_tag_list: - nonempty_llist(name_tag) - { $1 } -; -(* A method list (in an object type). *) -meth_list: - head = field_semi tail = meth_list - | head = inherit_field SEMI tail = meth_list - { let (f, c) = tail in (head :: f, c) } - | head = field_semi - | head = inherit_field SEMI - { [head], Closed } - | head = field - | head = inherit_field - { [head], Closed } - | DOTDOT - { [], Open } -; -%inline field: - mkrhs(label) COLON poly_type_no_attr attributes - { let info = symbol_info $endpos in - let attrs = add_info_attrs info $4 in - Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 } -; - -%inline field_semi: - mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes - { let info = - match rhs_info $endpos($4) with - | Some _ as info_before_semi -> info_before_semi - | None -> symbol_info $endpos - in - let attrs = add_info_attrs info ($4 @ $6) in - Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 } -; - -%inline inherit_field: - ty = atomic_type - { Of.inherit_ ~loc:(make_loc $sloc) ty } -; - -%inline label: - LIDENT { $1 } -; - -/* Constants */ - -constant: - | INT { let (n, m) = $1 in Pconst_integer (n, m) } - | CHAR { Pconst_char $1 } - | STRING { let (s, strloc, d) = $1 in Pconst_string (s, strloc, d) } - | FLOAT { let (f, m) = $1 in Pconst_float (f, m) } -; -signed_constant: - constant { $1 } - | MINUS INT { let (n, m) = $2 in Pconst_integer("-" ^ n, m) } - | MINUS FLOAT { let (f, m) = $2 in Pconst_float("-" ^ f, m) } - | PLUS INT { let (n, m) = $2 in Pconst_integer (n, m) } - | PLUS FLOAT { let (f, m) = $2 in Pconst_float(f, m) } -; - -/* Identifiers and long identifiers */ - -ident: - UIDENT { $1 } - | LIDENT { $1 } -; -val_extra_ident: - | LPAREN operator RPAREN { $2 } - | LPAREN operator error { unclosed "(" $loc($1) ")" $loc($3) } - | LPAREN error { expecting $loc($2) "operator" } - | LPAREN MODULE error { expecting $loc($3) "module-expr" } -; -val_ident: - LIDENT { $1 } - | val_extra_ident { $1 } -; -operator: - PREFIXOP { $1 } - | LETOP { $1 } - | ANDOP { $1 } - | DOTOP LPAREN index_mod RPAREN { "."^ $1 ^"(" ^ $3 ^ ")" } - | DOTOP LPAREN index_mod RPAREN LESSMINUS { "."^ $1 ^ "(" ^ $3 ^ ")<-" } - | DOTOP LBRACKET index_mod RBRACKET { "."^ $1 ^"[" ^ $3 ^ "]" } - | DOTOP LBRACKET index_mod RBRACKET LESSMINUS { "."^ $1 ^ "[" ^ $3 ^ "]<-" } - | DOTOP LBRACE index_mod RBRACE { "."^ $1 ^"{" ^ $3 ^ "}" } - | DOTOP LBRACE index_mod RBRACE LESSMINUS { "."^ $1 ^ "{" ^ $3 ^ "}<-" } - | HASHOP { $1 } - | BANG { "!" } - | infix_operator { $1 } -; -%inline infix_operator: - | op = INFIXOP0 { op } - | op = INFIXOP1 { op } - | op = INFIXOP2 { op } - | op = INFIXOP3 { op } - | op = INFIXOP4 { op } - | PLUS {"+"} - | PLUSDOT {"+."} - | PLUSEQ {"+="} - | MINUS {"-"} - | MINUSDOT {"-."} - | STAR {"*"} - | PERCENT {"%"} - | EQUAL {"="} - | LESS {"<"} - | GREATER {">"} - | OR {"or"} - | BARBAR {"||"} - | AMPERSAND {"&"} - | AMPERAMPER {"&&"} - | COLONEQUAL {":="} -; -index_mod: -| { "" } -| SEMI DOTDOT { ";.." } -; - -%inline constr_extra_ident: - | LPAREN COLONCOLON RPAREN { "::" } -; -constr_extra_nonprefix_ident: - | LBRACKET RBRACKET { "[]" } - | LPAREN RPAREN { "()" } - | FALSE { "false" } - | TRUE { "true" } -; -constr_ident: - UIDENT { $1 } - | constr_extra_ident { $1 } - | constr_extra_nonprefix_ident { $1 } -; -constr_longident: - mod_longident %prec below_DOT { $1 } /* A.B.x vs (A).B.x */ - | mod_longident DOT constr_extra_ident { Ldot($1,$3) } - | constr_extra_ident { Lident $1 } - | constr_extra_nonprefix_ident { Lident $1 } -; -mk_longident(prefix,final): - | final { Lident $1 } - | prefix DOT final { Ldot($1,$3) } -; -val_longident: - mk_longident(mod_longident, val_ident) { $1 } -; -label_longident: - mk_longident(mod_longident, LIDENT) { $1 } -; -type_longident: - mk_longident(mod_ext_longident, LIDENT) { $1 } -; -mod_longident: - mk_longident(mod_longident, UIDENT) { $1 } -; -mod_ext_longident: - mk_longident(mod_ext_longident, UIDENT) { $1 } - | mod_ext_longident LPAREN mod_ext_longident RPAREN - { lapply ~loc:$sloc $1 $3 } - | mod_ext_longident LPAREN error - { expecting $loc($3) "module path" } -; -mty_longident: - mk_longident(mod_ext_longident,ident) { $1 } -; -clty_longident: - mk_longident(mod_ext_longident,LIDENT) { $1 } -; -class_longident: - mk_longident(mod_longident,LIDENT) { $1 } -; - -/* BEGIN AVOID */ -/* For compiler-libs: parse all valid longidents and a little more: - final identifiers which are value specific are accepted even when - the path prefix is only valid for types: (e.g. F(X).(::)) */ -any_longident: - | mk_longident (mod_ext_longident, - ident | constr_extra_ident | val_extra_ident { $1 } - ) { $1 } - | constr_extra_nonprefix_ident { Lident $1 } -; -/* END AVOID */ - -/* Toplevel directives */ - -toplevel_directive: - HASH dir = mkrhs(ident) - arg = ioption(mk_directive_arg(toplevel_directive_argument)) - { mk_directive ~loc:$sloc dir arg } -; - -%inline toplevel_directive_argument: - | STRING { let (s, _, _) = $1 in Pdir_string s } - | INT { let (n, m) = $1 in Pdir_int (n ,m) } - | val_longident { Pdir_ident $1 } - | mod_longident { Pdir_ident $1 } - | FALSE { Pdir_bool false } - | TRUE { Pdir_bool true } -; - -/* Miscellaneous */ - -(* The symbol epsilon can be used instead of an /* empty */ comment. *) -%inline epsilon: - /* empty */ - { () } -; - -%inline raw_string: - s = STRING - { let body, _, _ = s in body } -; - -name_tag: - BACKQUOTE ident { $2 } -; -rec_flag: - /* empty */ { Nonrecursive } - | REC { Recursive } -; -%inline nonrec_flag: - /* empty */ { Recursive } - | NONREC { Nonrecursive } -; -%inline no_nonrec_flag: - /* empty */ { Recursive } -/* BEGIN AVOID */ - | NONREC { not_expecting $loc "nonrec flag" } -/* END AVOID */ -; -direction_flag: - TO { Upto } - | DOWNTO { Downto } -; -private_flag: - inline_private_flag - { $1 } -; -%inline inline_private_flag: - /* empty */ { Public } - | PRIVATE { Private } -; -mutable_flag: - /* empty */ { Immutable } - | MUTABLE { Mutable } -; -virtual_flag: - /* empty */ { Concrete } - | VIRTUAL { Virtual } -; -mutable_virtual_flags: - /* empty */ - { Immutable, Concrete } - | MUTABLE - { Mutable, Concrete } - | VIRTUAL - { Immutable, Virtual } - | MUTABLE VIRTUAL - | VIRTUAL MUTABLE - { Mutable, Virtual } -; -private_virtual_flags: - /* empty */ { Public, Concrete } - | PRIVATE { Private, Concrete } - | VIRTUAL { Public, Virtual } - | PRIVATE VIRTUAL { Private, Virtual } - | VIRTUAL PRIVATE { Private, Virtual } -; -(* This nonterminal symbol indicates the definite presence of a VIRTUAL - keyword and the possible presence of a MUTABLE keyword. *) -virtual_with_mutable_flag: - | VIRTUAL { Immutable } - | MUTABLE VIRTUAL { Mutable } - | VIRTUAL MUTABLE { Mutable } -; -(* This nonterminal symbol indicates the definite presence of a VIRTUAL - keyword and the possible presence of a PRIVATE keyword. *) -virtual_with_private_flag: - | VIRTUAL { Public } - | PRIVATE VIRTUAL { Private } - | VIRTUAL PRIVATE { Private } -; -%inline no_override_flag: - /* empty */ { Fresh } -; -%inline override_flag: - /* empty */ { Fresh } - | BANG { Override } -; -subtractive: - | MINUS { "-" } - | MINUSDOT { "-." } -; -additive: - | PLUS { "+" } - | PLUSDOT { "+." } -; -optlabel: - | OPTLABEL { $1 } - | QUESTION LIDENT COLON { $2 } -; - -/* Attributes and extensions */ - -single_attr_id: - LIDENT { $1 } - | UIDENT { $1 } - | AND { "and" } - | AS { "as" } - | ASSERT { "assert" } - | BEGIN { "begin" } - | CLASS { "class" } - | CONSTRAINT { "constraint" } - | DO { "do" } - | DONE { "done" } - | DOWNTO { "downto" } - | ELSE { "else" } - | END { "end" } - | EXCEPTION { "exception" } - | EXTERNAL { "external" } - | FALSE { "false" } - | FOR { "for" } - | FUN { "fun" } - | FUNCTION { "function" } - | FUNCTOR { "functor" } - | IF { "if" } - | IN { "in" } - | INCLUDE { "include" } - | INHERIT { "inherit" } - | INITIALIZER { "initializer" } - | LAZY { "lazy" } - | LET { "let" } - | MATCH { "match" } - | METHOD { "method" } - | MODULE { "module" } - | MUTABLE { "mutable" } - | NEW { "new" } - | NONREC { "nonrec" } - | OBJECT { "object" } - | OF { "of" } - | OPEN { "open" } - | OR { "or" } - | PRIVATE { "private" } - | REC { "rec" } - | SIG { "sig" } - | STRUCT { "struct" } - | THEN { "then" } - | TO { "to" } - | TRUE { "true" } - | TRY { "try" } - | TYPE { "type" } - | VAL { "val" } - | VIRTUAL { "virtual" } - | WHEN { "when" } - | WHILE { "while" } - | WITH { "with" } -/* mod/land/lor/lxor/lsl/lsr/asr are not supported for now */ -; - -attr_id: - mkloc( - single_attr_id { $1 } - | single_attr_id DOT attr_id { $1 ^ "." ^ $3.txt } - ) { $1 } -; -attribute: - LBRACKETAT attr_id payload RBRACKET - { Attr.mk ~loc:(make_loc $sloc) $2 $3 } -; -post_item_attribute: - LBRACKETATAT attr_id payload RBRACKET - { Attr.mk ~loc:(make_loc $sloc) $2 $3 } -; -floating_attribute: - LBRACKETATATAT attr_id payload RBRACKET - { mark_symbol_docs $sloc; - Attr.mk ~loc:(make_loc $sloc) $2 $3 } -; -%inline post_item_attributes: - post_item_attribute* - { $1 } -; -%inline attributes: - attribute* - { $1 } -; -ext: - | /* empty */ { None } - | PERCENT attr_id { Some $2 } -; -%inline no_ext: - | /* empty */ { None } -/* BEGIN AVOID */ - | PERCENT attr_id { not_expecting $loc "extension" } -/* END AVOID */ -; -%inline ext_attributes: - ext attributes { $1, $2 } -; -extension: - | LBRACKETPERCENT attr_id payload RBRACKET { ($2, $3) } - | QUOTED_STRING_EXPR - { mk_quotedext ~loc:$sloc $1 } -; -item_extension: - | LBRACKETPERCENTPERCENT attr_id payload RBRACKET { ($2, $3) } - | QUOTED_STRING_ITEM - { mk_quotedext ~loc:$sloc $1 } -; -payload: - structure { PStr $1 } - | COLON signature { PSig $2 } - | COLON core_type { PTyp $2 } - | QUESTION pattern { PPat ($2, None) } - | QUESTION pattern WHEN seq_expr { PPat ($2, Some $4) } -; -%% diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli deleted file mode 100644 index 7bb13135e7..0000000000 --- a/parsing/parsetree.mli +++ /dev/null @@ -1,1067 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Abstract syntax tree produced by parsing - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Asttypes - -type constant = - | Pconst_integer of string * char option - (** Integer constants such as [3] [3l] [3L] [3n]. - - Suffixes [[g-z][G-Z]] are accepted by the parser. - Suffixes except ['l'], ['L'] and ['n'] are rejected by the typechecker - *) - | Pconst_char of char (** Character such as ['c']. *) - | Pconst_string of string * Location.t * string option - (** Constant string such as ["constant"] or - [{delim|other constant|delim}]. - - The location span the content of the string, without the delimiters. - *) - | Pconst_float of string * char option - (** Float constant such as [3.4], [2e5] or [1.4e-4]. - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - -type location_stack = Location.t list - -(** {1 Extension points} *) - -type attribute = { - attr_name : string loc; - attr_payload : payload; - attr_loc : Location.t; - } -(** Attributes such as [[\@id ARG]] and [[\@\@id ARG]]. - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - -and extension = string loc * payload -(** Extension points such as [[%id ARG] and [%%id ARG]]. - - Sub-language placeholder -- rejected by the typechecker. - *) - -and attributes = attribute list - -and payload = - | PStr of structure - | PSig of signature (** [: SIG] in an attribute or an extension point *) - | PTyp of core_type (** [: T] in an attribute or an extension point *) - | PPat of pattern * expression option - (** [? P] or [? P when E], in an attribute or an extension point *) - -(** {1 Core language} *) -(** {2 Type expressions} *) - -and core_type = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_loc_stack: location_stack; - ptyp_attributes: attributes; (** [... [\@id1] [\@id2]] *) - } - -and core_type_desc = - | Ptyp_any (** [_] *) - | Ptyp_var of string (** A type variable such as ['a] *) - | Ptyp_arrow of arg_label * core_type * core_type - (** [Ptyp_arrow(lbl, T1, T2)] represents: - - [T1 -> T2] when [lbl] is - {{!Asttypes.arg_label.Nolabel}[Nolabel]}, - - [~l:T1 -> T2] when [lbl] is - {{!Asttypes.arg_label.Labelled}[Labelled]}, - - [?l:T1 -> T2] when [lbl] is - {{!Asttypes.arg_label.Optional}[Optional]}. - *) - | Ptyp_tuple of core_type list - (** [Ptyp_tuple([T1 ; ... ; Tn])] - represents a product type [T1 * ... * Tn]. - - Invariant: [n >= 2]. - *) - | Ptyp_constr of Longident.t loc * core_type list - (** [Ptyp_constr(lident, l)] represents: - - [tconstr] when [l=[]], - - [T tconstr] when [l=[T]], - - [(T1, ..., Tn) tconstr] when [l=[T1 ; ... ; Tn]]. - *) - | Ptyp_object of object_field list * closed_flag - (** [Ptyp_object([ l1:T1; ...; ln:Tn ], flag)] represents: - - [< l1:T1; ...; ln:Tn >] when [flag] is - {{!Asttypes.closed_flag.Closed}[Closed]}, - - [< l1:T1; ...; ln:Tn; .. >] when [flag] is - {{!Asttypes.closed_flag.Open}[Open]}. - *) - | Ptyp_class of Longident.t loc * core_type list - (** [Ptyp_class(tconstr, l)] represents: - - [#tconstr] when [l=[]], - - [T #tconstr] when [l=[T]], - - [(T1, ..., Tn) #tconstr] when [l=[T1 ; ... ; Tn]]. - *) - | Ptyp_alias of core_type * string (** [T as 'a]. *) - | Ptyp_variant of row_field list * closed_flag * label list option - (** [Ptyp_variant([`A;`B], flag, labels)] represents: - - [[ `A|`B ]] - when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, - and [labels] is [None], - - [[> `A|`B ]] - when [flag] is {{!Asttypes.closed_flag.Open}[Open]}, - and [labels] is [None], - - [[< `A|`B ]] - when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, - and [labels] is [Some []], - - [[< `A|`B > `X `Y ]] - when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, - and [labels] is [Some ["X";"Y"]]. - *) - | Ptyp_poly of string loc list * core_type - (** ['a1 ... 'an. T] - - Can only appear in the following context: - - - As the {!core_type} of a - {{!pattern_desc.Ppat_constraint}[Ppat_constraint]} node corresponding - to a constraint on a let-binding: - {[let x : 'a1 ... 'an. T = e ...]} - - - Under {{!class_field_kind.Cfk_virtual}[Cfk_virtual]} for methods - (not values). - - - As the {!core_type} of a - {{!class_type_field_desc.Pctf_method}[Pctf_method]} node. - - - As the {!core_type} of a {{!expression_desc.Pexp_poly}[Pexp_poly]} - node. - - - As the {{!label_declaration.pld_type}[pld_type]} field of a - {!label_declaration}. - - - As a {!core_type} of a {{!core_type_desc.Ptyp_object}[Ptyp_object]} - node. - - - As the {{!value_description.pval_type}[pval_type]} field of a - {!value_description}. - *) - | Ptyp_package of package_type (** [(module S)]. *) - | Ptyp_extension of extension (** [[%id]]. *) - -and package_type = Longident.t loc * (Longident.t loc * core_type) list -(** As {!package_type} typed values: - - [(S, [])] represents [(module S)], - - [(S, [(t1, T1) ; ... ; (tn, Tn)])] - represents [(module S with type t1 = T1 and ... and tn = Tn)]. - *) - -and row_field = { - prf_desc : row_field_desc; - prf_loc : Location.t; - prf_attributes : attributes; -} - -and row_field_desc = - | Rtag of label loc * bool * core_type list - (** [Rtag(`A, b, l)] represents: - - [`A] when [b] is [true] and [l] is [[]], - - [`A of T] when [b] is [false] and [l] is [[T]], - - [`A of T1 & .. & Tn] when [b] is [false] and [l] is [[T1;...Tn]], - - [`A of & T1 & .. & Tn] when [b] is [true] and [l] is [[T1;...Tn]]. - - - The [bool] field is true if the tag contains a - constant (empty) constructor. - - [&] occurs when several types are used for the same constructor - (see 4.2 in the manual) - *) - | Rinherit of core_type (** [[ | t ]] *) - -and object_field = { - pof_desc : object_field_desc; - pof_loc : Location.t; - pof_attributes : attributes; -} - -and object_field_desc = - | Otag of label loc * core_type - | Oinherit of core_type - -(** {2 Patterns} *) - -and pattern = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_loc_stack: location_stack; - ppat_attributes: attributes; (** [... [\@id1] [\@id2]] *) - } - -and pattern_desc = - | Ppat_any (** The pattern [_]. *) - | Ppat_var of string loc (** A variable pattern such as [x] *) - | Ppat_alias of pattern * string loc - (** An alias pattern such as [P as 'a] *) - | Ppat_constant of constant - (** Patterns such as [1], ['a'], ["true"], [1.0], [1l], [1L], [1n] *) - | Ppat_interval of constant * constant - (** Patterns such as ['a'..'z']. - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (** Patterns [(P1, ..., Pn)]. - - Invariant: [n >= 2] - *) - | Ppat_construct of Longident.t loc * (string loc list * pattern) option - (** [Ppat_construct(C, args)] represents: - - [C] when [args] is [None], - - [C P] when [args] is [Some ([], P)] - - [C (P1, ..., Pn)] when [args] is - [Some ([], Ppat_tuple [P1; ...; Pn])] - - [C (type a b) P] when [args] is [Some ([a; b], P)] - *) - | Ppat_variant of label * pattern option - (** [Ppat_variant(`A, pat)] represents: - - [`A] when [pat] is [None], - - [`A P] when [pat] is [Some P] - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (** [Ppat_record([(l1, P1) ; ... ; (ln, Pn)], flag)] represents: - - [{ l1=P1; ...; ln=Pn }] - when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]} - - [{ l1=P1; ...; ln=Pn; _}] - when [flag] is {{!Asttypes.closed_flag.Open}[Open]} - - Invariant: [n > 0] - *) - | Ppat_array of pattern list (** Pattern [[| P1; ...; Pn |]] *) - | Ppat_or of pattern * pattern (** Pattern [P1 | P2] *) - | Ppat_constraint of pattern * core_type (** Pattern [(P : T)] *) - | Ppat_type of Longident.t loc (** Pattern [#tconst] *) - | Ppat_lazy of pattern (** Pattern [lazy P] *) - | Ppat_unpack of string option loc - (** [Ppat_unpack(s)] represents: - - [(module P)] when [s] is [Some "P"] - - [(module _)] when [s] is [None] - - Note: [(module P : S)] is represented as - [Ppat_constraint(Ppat_unpack(Some "P"), Ptyp_package S)] - *) - | Ppat_exception of pattern (** Pattern [exception P] *) - | Ppat_extension of extension (** Pattern [[%id]] *) - | Ppat_open of Longident.t loc * pattern (** Pattern [M.(P)] *) - -(** {2 Value expressions} *) - -and expression = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_loc_stack: location_stack; - pexp_attributes: attributes; (** [... [\@id1] [\@id2]] *) - } - -and expression_desc = - | Pexp_ident of Longident.t loc - (** Identifiers such as [x] and [M.x] - *) - | Pexp_constant of constant - (** Expressions constant such as [1], ['a'], ["true"], [1.0], [1l], - [1L], [1n] *) - | Pexp_let of rec_flag * value_binding list * expression - (** [Pexp_let(flag, [(P1,E1) ; ... ; (Pn,En)], E)] represents: - - [let P1 = E1 and ... and Pn = EN in E] - when [flag] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, - - [let rec P1 = E1 and ... and Pn = EN in E] - when [flag] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. - *) - | Pexp_function of case list (** [function P1 -> E1 | ... | Pn -> En] *) - | Pexp_fun of arg_label * expression option * pattern * expression - (** [Pexp_fun(lbl, exp0, P, E1)] represents: - - [fun P -> E1] - when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} - and [exp0] is [None] - - [fun ~l:P -> E1] - when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} - and [exp0] is [None] - - [fun ?l:P -> E1] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [None] - - [fun ?l:(P = E0) -> E1] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [Some E0] - - Notes: - - If [E0] is provided, only - {{!Asttypes.arg_label.Optional}[Optional]} is allowed. - - [fun P1 P2 .. Pn -> E1] is represented as nested - {{!expression_desc.Pexp_fun}[Pexp_fun]}. - - [let f P = E] is represented using - {{!expression_desc.Pexp_fun}[Pexp_fun]}. - *) - | Pexp_apply of expression * (arg_label * expression) list - (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] - represents [E0 ~l1:E1 ... ~ln:En] - - [li] can be - {{!Asttypes.arg_label.Nolabel}[Nolabel]} (non labeled argument), - {{!Asttypes.arg_label.Labelled}[Labelled]} (labelled arguments) or - {{!Asttypes.arg_label.Optional}[Optional]} (optional argument). - - Invariant: [n > 0] - *) - | Pexp_match of expression * case list - (** [match E0 with P1 -> E1 | ... | Pn -> En] *) - | Pexp_try of expression * case list - (** [try E0 with P1 -> E1 | ... | Pn -> En] *) - | Pexp_tuple of expression list - (** Expressions [(E1, ..., En)] - - Invariant: [n >= 2] - *) - | Pexp_construct of Longident.t loc * expression option - (** [Pexp_construct(C, exp)] represents: - - [C] when [exp] is [None], - - [C E] when [exp] is [Some E], - - [C (E1, ..., En)] when [exp] is [Some (Pexp_tuple[E1;...;En])] - *) - | Pexp_variant of label * expression option - (** [Pexp_variant(`A, exp)] represents - - [`A] when [exp] is [None] - - [`A E] when [exp] is [Some E] - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (** [Pexp_record([(l1,P1) ; ... ; (ln,Pn)], exp0)] represents - - [{ l1=P1; ...; ln=Pn }] when [exp0] is [None] - - [{ E0 with l1=P1; ...; ln=Pn }] when [exp0] is [Some E0] - - Invariant: [n > 0] - *) - | Pexp_field of expression * Longident.t loc (** [E.l] *) - | Pexp_setfield of expression * Longident.t loc * expression - (** [E1.l <- E2] *) - | Pexp_array of expression list (** [[| E1; ...; En |]] *) - | Pexp_ifthenelse of expression * expression * expression option - (** [if E1 then E2 else E3] *) - | Pexp_sequence of expression * expression (** [E1; E2] *) - | Pexp_while of expression * expression (** [while E1 do E2 done] *) - | Pexp_for of pattern * expression * expression * direction_flag * expression - (** [Pexp_for(i, E1, E2, direction, E3)] represents: - - [for i = E1 to E2 do E3 done] - when [direction] is {{!Asttypes.direction_flag.Upto}[Upto]} - - [for i = E1 downto E2 do E3 done] - when [direction] is {{!Asttypes.direction_flag.Downto}[Downto]} - *) - | Pexp_constraint of expression * core_type (** [(E : T)] *) - | Pexp_coerce of expression * core_type option * core_type - (** [Pexp_coerce(E, from, T)] represents - - [(E :> T)] when [from] is [None], - - [(E : T0 :> T)] when [from] is [Some T0]. - *) - | Pexp_send of expression * label loc (** [E # m] *) - | Pexp_new of Longident.t loc (** [new M.c] *) - | Pexp_setinstvar of label loc * expression (** [x <- 2] *) - | Pexp_override of (label loc * expression) list - (** [{< x1 = E1; ...; xn = En >}] *) - | Pexp_letmodule of string option loc * module_expr * expression - (** [let module M = ME in E] *) - | Pexp_letexception of extension_constructor * expression - (** [let exception C in E] *) - | Pexp_assert of expression - (** [assert E]. - - Note: [assert false] is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression (** [lazy E] *) - | Pexp_poly of expression * core_type option - (** Used for method bodies. - - Can only be used as the expression under - {{!class_field_kind.Cfk_concrete}[Cfk_concrete]} for methods (not - values). *) - | Pexp_object of class_structure (** [object ... end] *) - | Pexp_newtype of string loc * expression (** [fun (type t) -> E] *) - | Pexp_pack of module_expr - (** [(module ME)]. - - [(module ME : S)] is represented as - [Pexp_constraint(Pexp_pack ME, Ptyp_package S)] *) - | Pexp_open of open_declaration * expression - (** - [M.(E)] - - [let open M in E] - - [let open! M in E] *) - | Pexp_letop of letop - (** - [let* P = E0 in E1] - - [let* P0 = E00 and* P1 = E01 in E1] *) - | Pexp_extension of extension (** [[%id]] *) - | Pexp_unreachable (** [.] *) - -and case = - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } -(** Values of type {!case} represents [(P -> E)] or [(P when E0 -> E)] *) - -and letop = - { - let_ : binding_op; - ands : binding_op list; - body : expression; - } - -and binding_op = - { - pbop_op : string loc; - pbop_pat : pattern; - pbop_exp : expression; - pbop_loc : Location.t; - } - -(** {2 Value descriptions} *) - -and value_description = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - pval_loc: Location.t; - } -(** Values of type {!value_description} represents: - - [val x: T], - when {{!value_description.pval_prim}[pval_prim]} is [[]] - - [external x: T = "s1" ... "sn"] - when {{!value_description.pval_prim}[pval_prim]} is [["s1";..."sn"]] -*) - -(** {2 Type declarations} *) - -and type_declaration = - { - ptype_name: string loc; - ptype_params: (core_type * (variance * injectivity)) list; - (** [('a1,...'an) t] *) - ptype_cstrs: (core_type * core_type * Location.t) list; - (** [... constraint T1=T1' ... constraint Tn=Tn'] *) - ptype_kind: type_kind; - ptype_private: private_flag; (** for [= private ...] *) - ptype_manifest: core_type option; (** represents [= T] *) - ptype_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - ptype_loc: Location.t; - } -(** - Here are type declarations and their representation, - for various {{!type_declaration.ptype_kind}[ptype_kind]} - and {{!type_declaration.ptype_manifest}[ptype_manifest]} values: - - [type t] when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, - and [manifest] is [None], - - [type t = T0] - when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, - and [manifest] is [Some T0], - - [type t = C of T | ...] - when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, - and [manifest] is [None], - - [type t = T0 = C of T | ...] - when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, - and [manifest] is [Some T0], - - [type t = {l: T; ...}] - when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, - and [manifest] is [None], - - [type t = T0 = {l : T; ...}] - when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, - and [manifest] is [Some T0], - - [type t = ..] - when [type_kind] is {{!type_kind.Ptype_open}[Ptype_open]}, - and [manifest] is [None]. -*) - -and type_kind = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - | Ptype_record of label_declaration list (** Invariant: non-empty list *) - | Ptype_open - -and label_declaration = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (** [l : T [\@id1] [\@id2]] *) - } -(** - - [{ ...; l: T; ... }] - when {{!label_declaration.pld_mutable}[pld_mutable]} - is {{!Asttypes.mutable_flag.Immutable}[Immutable]}, - - [{ ...; mutable l: T; ... }] - when {{!label_declaration.pld_mutable}[pld_mutable]} - is {{!Asttypes.mutable_flag.Mutable}[Mutable]}. - - Note: [T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}. -*) - -and constructor_declaration = - { - pcd_name: string loc; - pcd_vars: string loc list; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (** [C of ... [\@id1] [\@id2]] *) - } - -and constructor_arguments = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - (** Values of type {!constructor_declaration} - represents the constructor arguments of: - - [C of T1 * ... * Tn] when [res = None], - and [args = Pcstr_tuple [T1; ... ; Tn]], - - [C: T0] when [res = Some T0], - and [args = Pcstr_tuple []], - - [C: T1 * ... * Tn -> T0] when [res = Some T0], - and [args = Pcstr_tuple [T1; ... ; Tn]], - - [C of {...}] when [res = None], - and [args = Pcstr_record [...]], - - [C: {...} -> T0] when [res = Some T0], - and [args = Pcstr_record [...]]. -*) - -and type_extension = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * (variance * injectivity)) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_loc: Location.t; - ptyext_attributes: attributes; (** ... [\@\@id1] [\@\@id2] *) - } -(** - Definition of new extensions constructors for the extensive sum type [t] - ([type t += ...]). -*) - -and extension_constructor = - { - pext_name: string loc; - pext_kind: extension_constructor_kind; - pext_loc: Location.t; - pext_attributes: attributes; (** [C of ... [\@id1] [\@id2]] *) - } - -and type_exception = - { - ptyexn_constructor : extension_constructor; - ptyexn_loc : Location.t; - ptyexn_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) - } -(** Definition of a new exception ([exception E]). *) - -and extension_constructor_kind = - | Pext_decl of string loc list * constructor_arguments * core_type option - (** [Pext_decl(existentials, c_args, t_opt)] - describes a new extension constructor. It can be: - - [C of T1 * ... * Tn] when: - {ul {- [existentials] is [[]],} - {- [c_args] is [[T1; ...; Tn]],} - {- [t_opt] is [None]}.} - - [C: T0] when - {ul {- [existentials] is [[]],} - {- [c_args] is [[]],} - {- [t_opt] is [Some T0].}} - - [C: T1 * ... * Tn -> T0] when - {ul {- [existentials] is [[]],} - {- [c_args] is [[T1; ...; Tn]],} - {- [t_opt] is [Some T0].}} - - [C: 'a... . T1 * ... * Tn -> T0] when - {ul {- [existentials] is [['a;...]],} - {- [c_args] is [[T1; ... ; Tn]],} - {- [t_opt] is [Some T0].}} - *) - | Pext_rebind of Longident.t loc - (** [Pext_rebind(D)] re-export the constructor [D] with the new name [C] *) - -(** {1 Class language} *) -(** {2 Type expressions for the class language} *) - -and class_type = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (** [... [\@id1] [\@id2]] *) - } - -and class_type_desc = - | Pcty_constr of Longident.t loc * core_type list - (** - [c] - - [['a1, ..., 'an] c] *) - | Pcty_signature of class_signature (** [object ... end] *) - | Pcty_arrow of arg_label * core_type * class_type - (** [Pcty_arrow(lbl, T, CT)] represents: - - [T -> CT] - when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]}, - - [~l:T -> CT] - when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]}, - - [?l:T -> CT] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]}. - *) - | Pcty_extension of extension (** [%id] *) - | Pcty_open of open_description * class_type (** [let open M in CT] *) - -and class_signature = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } -(** Values of type [class_signature] represents: - - [object('selfpat) ... end] - - [object ... end] when {{!class_signature.pcsig_self}[pcsig_self]} - is {{!core_type_desc.Ptyp_any}[Ptyp_any]} -*) - -and class_type_field = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - } - -and class_type_field_desc = - | Pctf_inherit of class_type (** [inherit CT] *) - | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (** [val x: T] *) - | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (** [method x: T] - - Note: [T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}. - *) - | Pctf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) - | Pctf_attribute of attribute (** [[\@\@\@id]] *) - | Pctf_extension of extension (** [[%%id]] *) - -and 'a class_infos = - { - pci_virt: virtual_flag; - pci_params: (core_type * (variance * injectivity)) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - } -(** Values of type [class_expr class_infos] represents: - - [class c = ...] - - [class ['a1,...,'an] c = ...] - - [class virtual c = ...] - - They are also used for "class type" declaration. -*) - -and class_description = class_type class_infos - -and class_type_declaration = class_type class_infos - -(** {2 Value expressions for the class language} *) - -and class_expr = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (** [... [\@id1] [\@id2]] *) - } - -and class_expr_desc = - | Pcl_constr of Longident.t loc * core_type list - (** [c] and [['a1, ..., 'an] c] *) - | Pcl_structure of class_structure (** [object ... end] *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (** [Pcl_fun(lbl, exp0, P, CE)] represents: - - [fun P -> CE] - when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} - and [exp0] is [None], - - [fun ~l:P -> CE] - when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} - and [exp0] is [None], - - [fun ?l:P -> CE] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [None], - - [fun ?l:(P = E0) -> CE] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [Some E0]. - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (** [Pcl_apply(CE, [(l1,E1) ; ... ; (ln,En)])] - represents [CE ~l1:E1 ... ~ln:En]. - [li] can be empty (non labeled argument) or start with [?] - (optional argument). - - Invariant: [n > 0] - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (** [Pcl_let(rec, [(P1, E1); ... ; (Pn, En)], CE)] represents: - - [let P1 = E1 and ... and Pn = EN in CE] - when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, - - [let rec P1 = E1 and ... and Pn = EN in CE] - when [rec] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. - *) - | Pcl_constraint of class_expr * class_type (** [(CE : CT)] *) - | Pcl_extension of extension (** [[%id]] *) - | Pcl_open of open_description * class_expr (** [let open M in CE] *) - -and class_structure = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } -(** Values of type {!class_structure} represents: - - [object(selfpat) ... end] - - [object ... end] when {{!class_structure.pcstr_self}[pcstr_self]} - is {{!pattern_desc.Ppat_any}[Ppat_any]} -*) - -and class_field = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - } - -and class_field_desc = - | Pcf_inherit of override_flag * class_expr * string loc option - (** [Pcf_inherit(flag, CE, s)] represents: - - [inherit CE] - when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} - and [s] is [None], - - [inherit CE as x] - when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} - and [s] is [Some x], - - [inherit! CE] - when [flag] is {{!Asttypes.override_flag.Override}[Override]} - and [s] is [None], - - [inherit! CE as x] - when [flag] is {{!Asttypes.override_flag.Override}[Override]} - and [s] is [Some x] - *) - | Pcf_val of (label loc * mutable_flag * class_field_kind) - (** [Pcf_val(x,flag, kind)] represents: - - [val x = E] - when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} - and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} - - [val virtual x: T] - when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} - and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} - - [val mutable x = E] - when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} - and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} - - [val mutable virtual x: T] - when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} - and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} - *) - | Pcf_method of (label loc * private_flag * class_field_kind) - (** - [method x = E] - ([E] can be a {{!expression_desc.Pexp_poly}[Pexp_poly]}) - - [method virtual x: T] - ([T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}) - *) - | Pcf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) - | Pcf_initializer of expression (** [initializer E] *) - | Pcf_attribute of attribute (** [[\@\@\@id]] *) - | Pcf_extension of extension (** [[%%id]] *) - -and class_field_kind = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - -and class_declaration = class_expr class_infos - -(** {1 Module language} *) -(** {2 Type expressions for the module language} *) - -and module_type = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (** [... [\@id1] [\@id2]] *) - } - -and module_type_desc = - | Pmty_ident of Longident.t loc (** [Pmty_ident(S)] represents [S] *) - | Pmty_signature of signature (** [sig ... end] *) - | Pmty_functor of functor_parameter * module_type - (** [functor(X : MT1) -> MT2] *) - | Pmty_with of module_type * with_constraint list (** [MT with ...] *) - | Pmty_typeof of module_expr (** [module type of ME] *) - | Pmty_extension of extension (** [[%id]] *) - | Pmty_alias of Longident.t loc (** [(module M)] *) - -and functor_parameter = - | Unit (** [()] *) - | Named of string option loc * module_type - (** [Named(name, MT)] represents: - - [(X : MT)] when [name] is [Some X], - - [(_ : MT)] when [name] is [None] *) - -and signature = signature_item list - -and signature_item = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - -and signature_item_desc = - | Psig_value of value_description - (** - [val x: T] - - [external x: T = "s1" ... "sn"] - *) - | Psig_type of rec_flag * type_declaration list - (** [type t1 = ... and ... and tn = ...] *) - | Psig_typesubst of type_declaration list - (** [type t1 := ... and ... and tn := ...] *) - | Psig_typext of type_extension (** [type t1 += ...] *) - | Psig_exception of type_exception (** [exception C of T] *) - | Psig_module of module_declaration (** [module X = M] and [module X : MT] *) - | Psig_modsubst of module_substitution (** [module X := M] *) - | Psig_recmodule of module_declaration list - (** [module rec X1 : MT1 and ... and Xn : MTn] *) - | Psig_modtype of module_type_declaration - (** [module type S = MT] and [module type S] *) - | Psig_modtypesubst of module_type_declaration - (** [module type S := ...] *) - | Psig_open of open_description (** [open X] *) - | Psig_include of include_description (** [include MT] *) - | Psig_class of class_description list - (** [class c1 : ... and ... and cn : ...] *) - | Psig_class_type of class_type_declaration list - (** [class type ct1 = ... and ... and ctn = ...] *) - | Psig_attribute of attribute (** [[\@\@\@id]] *) - | Psig_extension of extension * attributes (** [[%%id]] *) - -and module_declaration = - { - pmd_name: string option loc; - pmd_type: module_type; - pmd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - pmd_loc: Location.t; - } -(** Values of type [module_declaration] represents [S : MT] *) - -and module_substitution = - { - pms_name: string loc; - pms_manifest: Longident.t loc; - pms_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - pms_loc: Location.t; - } -(** Values of type [module_substitution] represents [S := M] *) - -and module_type_declaration = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - pmtd_loc: Location.t; - } -(** Values of type [module_type_declaration] represents: - - [S = MT], - - [S] for abstract module type declaration, - when {{!module_type_declaration.pmtd_type}[pmtd_type]} is [None]. -*) - -and 'a open_infos = - { - popen_expr: 'a; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } -(** Values of type ['a open_infos] represents: - - [open! X] when {{!open_infos.popen_override}[popen_override]} - is {{!Asttypes.override_flag.Override}[Override]} - (silences the "used identifier shadowing" warning) - - [open X] when {{!open_infos.popen_override}[popen_override]} - is {{!Asttypes.override_flag.Fresh}[Fresh]} -*) - -and open_description = Longident.t loc open_infos -(** Values of type [open_description] represents: - - [open M.N] - - [open M(N).O] *) - -and open_declaration = module_expr open_infos -(** Values of type [open_declaration] represents: - - [open M.N] - - [open M(N).O] - - [open struct ... end] *) - -and 'a include_infos = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - -and include_description = module_type include_infos -(** Values of type [include_description] represents [include MT] *) - -and include_declaration = module_expr include_infos -(** Values of type [include_declaration] represents [include ME] *) - -and with_constraint = - | Pwith_type of Longident.t loc * type_declaration - (** [with type X.t = ...] - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (** [with module X.Y = Z] *) - | Pwith_modtype of Longident.t loc * module_type - (** [with module type X.Y = Z] *) - | Pwith_modtypesubst of Longident.t loc * module_type - (** [with module type X.Y := sig end] *) - | Pwith_typesubst of Longident.t loc * type_declaration - (** [with type X.t := ..., same format as [Pwith_type]] *) - | Pwith_modsubst of Longident.t loc * Longident.t loc - (** [with module X.Y := Z] *) - -(** {2 Value expressions for the module language} *) - -and module_expr = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (** [... [\@id1] [\@id2]] *) - } - -and module_expr_desc = - | Pmod_ident of Longident.t loc (** [X] *) - | Pmod_structure of structure (** [struct ... end] *) - | Pmod_functor of functor_parameter * module_expr - (** [functor(X : MT1) -> ME] *) - | Pmod_apply of module_expr * module_expr (** [ME1(ME2)] *) - | Pmod_apply_unit of module_expr (** [ME1()] *) - | Pmod_constraint of module_expr * module_type (** [(ME : MT)] *) - | Pmod_unpack of expression (** [(val E)] *) - | Pmod_extension of extension (** [[%id]] *) - -and structure = structure_item list - -and structure_item = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - -and structure_item_desc = - | Pstr_eval of expression * attributes (** [E] *) - | Pstr_value of rec_flag * value_binding list - (** [Pstr_value(rec, [(P1, E1 ; ... ; (Pn, En))])] represents: - - [let P1 = E1 and ... and Pn = EN] - when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, - - [let rec P1 = E1 and ... and Pn = EN ] - when [rec] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. - *) - | Pstr_primitive of value_description - (** - [val x: T] - - [external x: T = "s1" ... "sn" ]*) - | Pstr_type of rec_flag * type_declaration list - (** [type t1 = ... and ... and tn = ...] *) - | Pstr_typext of type_extension (** [type t1 += ...] *) - | Pstr_exception of type_exception - (** - [exception C of T] - - [exception C = M.X] *) - | Pstr_module of module_binding (** [module X = ME] *) - | Pstr_recmodule of module_binding list - (** [module rec X1 = ME1 and ... and Xn = MEn] *) - | Pstr_modtype of module_type_declaration (** [module type S = MT] *) - | Pstr_open of open_declaration (** [open X] *) - | Pstr_class of class_declaration list - (** [class c1 = ... and ... and cn = ...] *) - | Pstr_class_type of class_type_declaration list - (** [class type ct1 = ... and ... and ctn = ...] *) - | Pstr_include of include_declaration (** [include ME] *) - | Pstr_attribute of attribute (** [[\@\@\@id]] *) - | Pstr_extension of extension * attributes (** [[%%id]] *) - -and value_constraint = - | Pvc_constraint of { - locally_abstract_univars:string loc list; - typ:core_type; - } - | Pvc_coercion of {ground:core_type option; coercion:core_type } - (** - - [Pvc_constraint { locally_abstract_univars=[]; typ}] - is a simple type constraint on a value binding: [ let x : typ] - - More generally, in [Pvc_constraint { locally_abstract_univars; typ}] - [locally_abstract_univars] is the list of locally abstract type - variables in [ let x: type a ... . typ ] - - [Pvc_coercion { ground=None; coercion }] represents [let x :> typ] - - [Pvc_coercion { ground=Some g; coercion }] represents [let x : g :> typ] - *) - -and value_binding = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_constraint: value_constraint option; - pvb_attributes: attributes; - pvb_loc: Location.t; - }(** [let pat : type_constraint = exp] *) - -and module_binding = - { - pmb_name: string option loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } -(** Values of type [module_binding] represents [module X = ME] *) - -(** {1 Toplevel} *) - -(** {2 Toplevel phrases} *) - -type toplevel_phrase = - | Ptop_def of structure - | Ptop_dir of toplevel_directive (** [#use], [#load] ... *) - -and toplevel_directive = - { - pdir_name: string loc; - pdir_arg: directive_argument option; - pdir_loc: Location.t; - } - -and directive_argument = - { - pdira_desc: directive_argument_desc; - pdira_loc: Location.t; - } - -and directive_argument_desc = - | Pdir_string of string - | Pdir_int of string * char option - | Pdir_ident of Longident.t - | Pdir_bool of bool diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml deleted file mode 100644 index 9c1d7a0880..0000000000 --- a/parsing/pprintast.ml +++ /dev/null @@ -1,1677 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire, OCamlPro *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* Hongbo Zhang, University of Pennsylvania *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) -(* Printing code expressions *) -(* Authors: Ed Pizzi, Fabrice Le Fessant *) -(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) -(* TODO more fine-grained precedence pretty-printing *) - -open Asttypes -open Format -open Location -open Longident -open Parsetree - -let prefix_symbols = [ '!'; '?'; '~' ] -let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; - '$'; '%'; '#' ] - -(* type fixity = Infix| Prefix *) -let special_infix_strings = - ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] - -let letop s = - String.length s > 3 - && s.[0] = 'l' - && s.[1] = 'e' - && s.[2] = 't' - && List.mem s.[3] infix_symbols - -let andop s = - String.length s > 3 - && s.[0] = 'a' - && s.[1] = 'n' - && s.[2] = 'd' - && List.mem s.[3] infix_symbols - -(* determines if the string is an infix string. - checks backwards, first allowing a renaming postfix ("_102") which - may have resulted from Pexp -> Texp -> Pexp translation, then checking - if all the characters in the beginning of the string are valid infix - characters. *) -let fixity_of_string = function - | "" -> `Normal - | s when List.mem s special_infix_strings -> `Infix s - | s when List.mem s.[0] infix_symbols -> `Infix s - | s when List.mem s.[0] prefix_symbols -> `Prefix s - | s when s.[0] = '.' -> `Mixfix s - | s when letop s -> `Letop s - | s when andop s -> `Andop s - | _ -> `Normal - -let view_fixity_of_exp = function - | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} -> - fixity_of_string l - | _ -> `Normal - -let is_infix = function `Infix _ -> true | _ -> false -let is_mixfix = function `Mixfix _ -> true | _ -> false -let is_kwdop = function `Letop _ | `Andop _ -> true | _ -> false - -let first_is c str = - str <> "" && str.[0] = c -let last_is c str = - str <> "" && str.[String.length str - 1] = c - -let first_is_in cs str = - str <> "" && List.mem str.[0] cs - -(* which identifiers are in fact operators needing parentheses *) -let needs_parens txt = - let fix = fixity_of_string txt in - is_infix fix - || is_mixfix fix - || is_kwdop fix - || first_is_in prefix_symbols txt - -(* some infixes need spaces around parens to avoid clashes with comment - syntax *) -let needs_spaces txt = - first_is '*' txt || last_is '*' txt - -let string_loc ppf x = fprintf ppf "%s" x.txt - -(* add parentheses to binders when they are in fact infix or prefix operators *) -let protect_ident ppf txt = - let format : (_, _, _) format = - if not (needs_parens txt) then "%s" - else if needs_spaces txt then "(@;%s@;)" - else "(%s)" - in fprintf ppf format txt - -let protect_longident ppf print_longident longprefix txt = - let format : (_, _, _) format = - if not (needs_parens txt) then "%a.%s" - else if needs_spaces txt then "%a.(@;%s@;)" - else "%a.(%s)" in - fprintf ppf format print_longident longprefix txt - -type space_formatter = (unit, Format.formatter, unit) format - -let override = function - | Override -> "!" - | Fresh -> "" - -(* variance encoding: need to sync up with the [parser.mly] *) -let type_variance = function - | NoVariance -> "" - | Covariant -> "+" - | Contravariant -> "-" - -let type_injectivity = function - | NoInjectivity -> "" - | Injective -> "!" - -type construct = - [ `cons of expression list - | `list of expression list - | `nil - | `normal - | `simple of Longident.t - | `tuple ] - -let view_expr x = - match x.pexp_desc with - | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple - | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil - | Pexp_construct ( {txt= Lident"::";_},Some _) -> - let rec loop exp acc = match exp with - | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_); - pexp_attributes = []} -> - (List.rev acc,true) - | {pexp_desc= - Pexp_construct ({txt=Lident "::";_}, - Some ({pexp_desc= Pexp_tuple([e1;e2]); - pexp_attributes = []})); - pexp_attributes = []} - -> - loop e2 (e1::acc) - | e -> (List.rev (e::acc),false) in - let (ls,b) = loop x [] in - if b then - `list ls - else `cons ls - | Pexp_construct (x,None) -> `simple (x.txt) - | _ -> `normal - -let is_simple_construct :construct -> bool = function - | `nil | `tuple | `list _ | `simple _ -> true - | `cons _ | `normal -> false - -let pp = fprintf - -type ctxt = { - pipe : bool; - semi : bool; - ifthenelse : bool; -} - -let reset_ctxt = { pipe=false; semi=false; ifthenelse=false } -let under_pipe ctxt = { ctxt with pipe=true } -let under_semi ctxt = { ctxt with semi=true } -let under_ifthenelse ctxt = { ctxt with ifthenelse=true } -(* -let reset_semi ctxt = { ctxt with semi=false } -let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } -let reset_pipe ctxt = { ctxt with pipe=false } -*) - -let list : 'a . ?sep:space_formatter -> ?first:space_formatter -> - ?last:space_formatter -> (Format.formatter -> 'a -> unit) -> - Format.formatter -> 'a list -> unit - = fun ?sep ?first ?last fu f xs -> - let first = match first with Some x -> x |None -> ("": _ format6) - and last = match last with Some x -> x |None -> ("": _ format6) - and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in - let aux f = function - | [] -> () - | [x] -> fu f x - | xs -> - let rec loop f = function - | [x] -> fu f x - | x::xs -> fu f x; pp f sep; loop f xs; - | _ -> assert false in begin - pp f first; loop f xs; pp f last; - end in - aux f xs - -let option : 'a. ?first:space_formatter -> ?last:space_formatter -> - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit - = fun ?first ?last fu f a -> - let first = match first with Some x -> x | None -> ("": _ format6) - and last = match last with Some x -> x | None -> ("": _ format6) in - match a with - | None -> () - | Some x -> pp f first; fu f x; pp f last - -let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> - bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit - = fun ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x -> - if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") - else fu f x - -let rec longident f = function - | Lident s -> protect_ident f s - | Ldot(y,s) -> protect_longident f longident y s - | Lapply (y,s) -> - pp f "%a(%a)" longident y longident s - -let longident_loc f x = pp f "%a" longident x.txt - -let constant f = function - | Pconst_char i -> - pp f "%C" i - | Pconst_string (i, _, None) -> - pp f "%S" i - | Pconst_string (i, _, Some delim) -> - pp f "{%s|%s|%s}" delim i delim - | Pconst_integer (i, None) -> - paren (first_is '-' i) (fun f -> pp f "%s") f i - | Pconst_integer (i, Some m) -> - paren (first_is '-' i) (fun f (i, m) -> pp f "%s%c" i m) f (i,m) - | Pconst_float (i, None) -> - paren (first_is '-' i) (fun f -> pp f "%s") f i - | Pconst_float (i, Some m) -> - paren (first_is '-' i) (fun f (i,m) -> pp f "%s%c" i m) f (i,m) - -(* trailing space*) -let mutable_flag f = function - | Immutable -> () - | Mutable -> pp f "mutable@;" -let virtual_flag f = function - | Concrete -> () - | Virtual -> pp f "virtual@;" - -(* trailing space added *) -let rec_flag f rf = - match rf with - | Nonrecursive -> () - | Recursive -> pp f "rec " -let nonrec_flag f rf = - match rf with - | Nonrecursive -> pp f "nonrec " - | Recursive -> () -let direction_flag f = function - | Upto -> pp f "to@ " - | Downto -> pp f "downto@ " -let private_flag f = function - | Public -> () - | Private -> pp f "private@ " - -let iter_loc f ctxt {txt; loc = _} = f ctxt txt - -let constant_string f s = pp f "%S" s - -let tyvar ppf s = - if String.length s >= 2 && s.[1] = '\'' then - (* without the space, this would be parsed as - a character literal *) - Format.fprintf ppf "' %s" s - else - Format.fprintf ppf "'%s" s - -let tyvar_loc f str = tyvar f str.txt -let string_quot f x = pp f "`%s" x - -(* c ['a,'b] *) -let rec class_params_def ctxt f = function - | [] -> () - | l -> - pp f "[%a] " (* space *) - (list (type_param ctxt) ~sep:",") l - -and type_with_label ctxt f (label, c) = - match label with - | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) - | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c - | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c - -and core_type ctxt f x = - if x.ptyp_attributes <> [] then begin - pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]} - (attributes ctxt) x.ptyp_attributes - end - else match x.ptyp_desc with - | Ptyp_arrow (l, ct1, ct2) -> - pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 - | Ptyp_alias (ct, s) -> - pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s - | Ptyp_poly ([], ct) -> - core_type ctxt f ct - | Ptyp_poly (sl, ct) -> - pp f "@[<2>%a%a@]" - (fun f l -> match l with - | [] -> () - | _ -> - pp f "%a@;.@;" - (list tyvar_loc ~sep:"@;") l) - sl (core_type ctxt) ct - | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x - -and core_type1 ctxt f x = - if x.ptyp_attributes <> [] then core_type ctxt f x - else match x.ptyp_desc with - | Ptyp_any -> pp f "_"; - | Ptyp_var s -> tyvar f s; - | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l - | Ptyp_constr (li, l) -> - pp f (* "%a%a@;" *) "%a%a" - (fun f l -> match l with - |[] -> () - |[x]-> pp f "%a@;" (core_type1 ctxt) x - | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) - l longident_loc li - | Ptyp_variant (l, closed, low) -> - let first_is_inherit = match l with - | {Parsetree.prf_desc = Rinherit _}::_ -> true - | _ -> false in - let type_variant_helper f x = - match x.prf_desc with - | Rtag (l, _, ctl) -> - pp f "@[<2>%a%a@;%a@]" (iter_loc string_quot) l - (fun f l -> match l with - |[] -> () - | _ -> pp f "@;of@;%a" - (list (core_type ctxt) ~sep:"&") ctl) ctl - (attributes ctxt) x.prf_attributes - | Rinherit ct -> core_type ctxt f ct in - pp f "@[<2>[%a%a]@]" - (fun f l -> - match l, closed with - | [], Closed -> () - | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) - | _ -> - pp f "%s@;%a" - (match (closed,low) with - | (Closed,None) -> if first_is_inherit then " |" else "" - | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*) - | (Open,_) -> ">") - (list type_variant_helper ~sep:"@;<1 -2>| ") l) l - (fun f low -> match low with - |Some [] |None -> () - |Some xs -> - pp f ">@ %a" - (list string_quot) xs) low - | Ptyp_object (l, o) -> - let core_field_type f x = match x.pof_desc with - | Otag (l, ct) -> - (* Cf #7200 *) - pp f "@[%s: %a@ %a@ @]" l.txt - (core_type ctxt) ct (attributes ctxt) x.pof_attributes - | Oinherit ct -> - pp f "@[%a@ @]" (core_type ctxt) ct - in - let field_var f = function - | Asttypes.Closed -> () - | Asttypes.Open -> - match l with - | [] -> pp f ".." - | _ -> pp f " ;.." - in - pp f "@[<@ %a%a@ > @]" - (list core_field_type ~sep:";") l - field_var o (* Cf #7200 *) - | Ptyp_class (li, l) -> (*FIXME*) - pp f "@[%a#%a@]" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l - longident_loc li - | Ptyp_package (lid, cstrs) -> - let aux f (s, ct) = - pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct in - (match cstrs with - |[] -> pp f "@[(module@ %a)@]" longident_loc lid - |_ -> - pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid - (list aux ~sep:"@ and@ ") cstrs) - | Ptyp_extension e -> extension ctxt f e - | _ -> paren true (core_type ctxt) f x - -(********************pattern********************) -(* be cautious when use [pattern], [pattern1] is preferred *) -and pattern ctxt f x = - if x.ppat_attributes <> [] then begin - pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]} - (attributes ctxt) x.ppat_attributes - end - else match x.ppat_desc with - | Ppat_alias (p, s) -> - pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt - | _ -> pattern_or ctxt f x - -and pattern_or ctxt f x = - let rec left_associative x acc = match x with - | {ppat_desc=Ppat_or (p1,p2); ppat_attributes = []} -> - left_associative p1 (p2 :: acc) - | x -> x :: acc - in - match left_associative x [] with - | [] -> assert false - | [x] -> pattern1 ctxt f x - | orpats -> - pp f "@[%a@]" (list ~sep:"@ | " (pattern1 ctxt)) orpats - -and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = - let rec pattern_list_helper f = function - | {ppat_desc = - Ppat_construct - ({ txt = Lident("::") ;_}, - Some ([], {ppat_desc = Ppat_tuple([pat1; pat2]);_})); - ppat_attributes = []} - - -> - pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) - | p -> pattern1 ctxt f p - in - if x.ppat_attributes <> [] then pattern ctxt f x - else match x.ppat_desc with - | Ppat_variant (l, Some p) -> - pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p - | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> - simple_pattern ctxt f x - | Ppat_construct (({txt;_} as li), po) -> - (* FIXME The third field always false *) - if txt = Lident "::" then - pp f "%a" pattern_list_helper x - else - (match po with - | Some ([], x) -> - pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x - | Some (vl, x) -> - pp f "%a@ (type %a)@;%a" longident_loc li - (list ~sep:"@ " string_loc) vl - (simple_pattern ctxt) x - | None -> pp f "%a" longident_loc li) - | _ -> simple_pattern ctxt f x - -and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = - if x.ppat_attributes <> [] then pattern ctxt f x - else match x.ppat_desc with - | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), None) -> - pp f "%s" x - | Ppat_any -> pp f "_"; - | Ppat_var ({txt = txt;_}) -> protect_ident f txt - | Ppat_array l -> - pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l - | Ppat_unpack { txt = None } -> - pp f "(module@ _)@ " - | Ppat_unpack { txt = Some s } -> - pp f "(module@ %s)@ " s - | Ppat_type li -> - pp f "#%a" longident_loc li - | Ppat_record (l, closed) -> - let longident_x_pattern f (li, p) = - match (li,p) with - | ({txt=Lident s;_ }, - {ppat_desc=Ppat_var {txt;_}; - ppat_attributes=[]; _}) - when s = txt -> - pp f "@[<2>%a@]" longident_loc li - | _ -> - pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p - in - begin match closed with - | Closed -> - pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l - | _ -> - pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l - end - | Ppat_tuple l -> - pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) - | Ppat_constant (c) -> pp f "%a" constant c - | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 - | Ppat_variant (l,None) -> pp f "`%s" l - | Ppat_constraint (p, ct) -> - pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct - | Ppat_lazy p -> - pp f "@[<2>(lazy@;%a)@]" (simple_pattern ctxt) p - | Ppat_exception p -> - pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p - | Ppat_extension e -> extension ctxt f e - | Ppat_open (lid, p) -> - let with_paren = - match p.ppat_desc with - | Ppat_array _ | Ppat_record _ - | Ppat_construct (({txt=Lident ("()"|"[]");_}), None) -> false - | _ -> true in - pp f "@[<2>%a.%a @]" longident_loc lid - (paren with_paren @@ pattern1 ctxt) p - | _ -> paren true (pattern ctxt) f x - -and label_exp ctxt f (l,opt,p) = - match l with - | Nolabel -> - (* single case pattern parens needed here *) - pp f "%a@ " (simple_pattern ctxt) p - | Optional rest -> - begin match p with - | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} - when txt = rest -> - (match opt with - | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o - | None -> pp f "?%s@ " rest) - | _ -> - (match opt with - | Some o -> - pp f "?%s:(%a=@;%a)@;" - rest (pattern1 ctxt) p (expression ctxt) o - | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p) - end - | Labelled l -> match p with - | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} - when txt = l -> - pp f "~%s@;" l - | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p - -and sugar_expr ctxt f e = - if e.pexp_attributes <> [] then false - else match e.pexp_desc with - | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _}; - pexp_attributes=[]; _}, args) - when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin - let print_indexop a path_prefix assign left sep right print_index indices - rem_args = - let print_path ppf = function - | None -> () - | Some m -> pp ppf ".%a" longident m in - match assign, rem_args with - | false, [] -> - pp f "@[%a%a%s%a%s@]" - (simple_expr ctxt) a print_path path_prefix - left (list ~sep print_index) indices right; true - | true, [v] -> - pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" - (simple_expr ctxt) a print_path path_prefix - left (list ~sep print_index) indices right - (simple_expr ctxt) v; true - | _ -> false in - match id, List.map snd args with - | Lident "!", [e] -> - pp f "@[!%a@]" (simple_expr ctxt) e; true - | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin - let assign = func = "set" in - let print = print_indexop a None assign in - match path, other_args with - | Lident "Array", i :: rest -> - print ".(" "" ")" (expression ctxt) [i] rest - | Lident "String", i :: rest -> - print ".[" "" "]" (expression ctxt) [i] rest - | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> - print ".{" "," "}" (simple_expr ctxt) [i1] rest - | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> - print ".{" "," "}" (simple_expr ctxt) [i1; i2] rest - | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> - print ".{" "," "}" (simple_expr ctxt) [i1; i2; i3] rest - | Ldot (Lident "Bigarray", "Genarray"), - {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest -> - print ".{" "," "}" (simple_expr ctxt) indexes rest - | _ -> false - end - | (Lident s | Ldot(_,s)) , a :: i :: rest - when first_is '.' s -> - (* extract operator: - assignment operators end with [right_bracket ^ "<-"], - access operators end with [right_bracket] directly - *) - let multi_indices = String.contains s ';' in - let i = - match i.pexp_desc with - | Pexp_array l when multi_indices -> l - | _ -> [ i ] in - let assign = last_is '-' s in - let kind = - (* extract the right end bracket *) - let n = String.length s in - if assign then s.[n - 3] else s.[n - 1] in - let left, right = match kind with - | ')' -> '(', ")" - | ']' -> '[', "]" - | '}' -> '{', "}" - | _ -> assert false in - let path_prefix = match id with - | Ldot(m,_) -> Some m - | _ -> None in - let left = String.sub s 0 (1+String.index s left) in - print_indexop a path_prefix assign left ";" right - (if multi_indices then expression ctxt else simple_expr ctxt) - i rest - | _ -> false - end - | _ -> false - -and expression ctxt f x = - if x.pexp_attributes <> [] then - pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]} - (attributes ctxt) x.pexp_attributes - else match x.pexp_desc with - | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ - | Pexp_newtype _ - when ctxt.pipe || ctxt.semi -> - paren true (expression reset_ctxt) f x - | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse -> - paren true (expression reset_ctxt) f x - | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ - | Pexp_letexception _ | Pexp_letop _ - when ctxt.semi -> - paren true (expression reset_ctxt) f x - | Pexp_fun (l, e0, p, e) -> - pp f "@[<2>fun@;%a->@;%a@]" - (label_exp ctxt) (l, e0, p) - (expression ctxt) e - | Pexp_newtype (lid, e) -> - pp f "@[<2>fun@;(type@;%s)@;->@;%a@]" lid.txt - (expression ctxt) e - | Pexp_function l -> - pp f "@[function%a@]" (case_list ctxt) l - | Pexp_match (e, l) -> - pp f "@[@[@[<2>match %a@]@ with@]%a@]" - (expression reset_ctxt) e (case_list ctxt) l - - | Pexp_try (e, l) -> - pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" - (* "try@;@[<2>%a@]@\nwith@\n%a"*) - (expression reset_ctxt) e (case_list ctxt) l - | Pexp_let (rf, l, e) -> - (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" - (*no indentation here, a new line*) *) - (* rec_flag rf *) - pp f "@[<2>%a in@;<1 -2>%a@]" - (bindings reset_ctxt) (rf,l) - (expression ctxt) e - | Pexp_apply (e, l) -> - begin if not (sugar_expr ctxt f x) then - match view_fixity_of_exp e with - | `Infix s -> - begin match l with - | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] -> - (* FIXME associativity label_x_expression_param *) - pp f "@[<2>%a@;%s@;%a@]" - (label_x_expression_param reset_ctxt) arg1 s - (label_x_expression_param ctxt) arg2 - | _ -> - pp f "@[<2>%a %a@]" - (simple_expr ctxt) e - (list (label_x_expression_param ctxt)) l - end - | `Prefix s -> - let s = - if List.mem s ["~+";"~-";"~+.";"~-."] && - (match l with - (* See #7200: avoid turning (~- 1) into (- 1) which is - parsed as an int literal *) - |[(_,{pexp_desc=Pexp_constant _})] -> false - | _ -> true) - then String.sub s 1 (String.length s -1) - else s in - begin match l with - | [(Nolabel, x)] -> - pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x - | _ -> - pp f "@[<2>%a %a@]" (simple_expr ctxt) e - (list (label_x_expression_param ctxt)) l - end - | _ -> - pp f "@[%a@]" begin fun f (e,l) -> - pp f "%a@ %a" (expression2 ctxt) e - (list (label_x_expression_param reset_ctxt)) l - (* reset here only because [function,match,try,sequence] - are lower priority *) - end (e,l) - end - - | Pexp_construct (li, Some eo) - when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*) - (match view_expr x with - | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" - | `normal -> - pp f "@[<2>%a@;%a@]" longident_loc li - (simple_expr ctxt) eo - | _ -> assert false) - | Pexp_setfield (e1, li, e2) -> - pp f "@[<2>%a.%a@ <-@ %a@]" - (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2 - | Pexp_ifthenelse (e1, e2, eo) -> - (* @;@[<2>else@ %a@]@] *) - let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in - let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in - pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 - (fun f eo -> match eo with - | Some x -> - pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x - | None -> () (* pp f "()" *)) eo - | Pexp_sequence _ -> - let rec sequence_helper acc = function - | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} -> - sequence_helper (e1::acc) e2 - | v -> List.rev (v::acc) in - let lst = sequence_helper [] x in - pp f "@[%a@]" - (list (expression (under_semi ctxt)) ~sep:";@;") lst - | Pexp_new (li) -> - pp f "@[new@ %a@]" longident_loc li; - | Pexp_setinstvar (s, e) -> - pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e - | Pexp_override l -> (* FIXME *) - let string_x_expression f (s, e) = - pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in - pp f "@[{<%a>}@]" - (list string_x_expression ~sep:";" ) l; - | Pexp_letmodule (s, me, e) -> - pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" - (Option.value s.txt ~default:"_") - (module_expr reset_ctxt) me (expression ctxt) e - | Pexp_letexception (cd, e) -> - pp f "@[let@ exception@ %a@ in@ %a@]" - (extension_constructor ctxt) cd - (expression ctxt) e - | Pexp_assert e -> - pp f "@[assert@ %a@]" (simple_expr ctxt) e - | Pexp_lazy (e) -> - pp f "@[lazy@ %a@]" (simple_expr ctxt) e - (* Pexp_poly: impossible but we should print it anyway, rather than - assert false *) - | Pexp_poly (e, None) -> - pp f "@[!poly!@ %a@]" (simple_expr ctxt) e - | Pexp_poly (e, Some ct) -> - pp f "@[(!poly!@ %a@ : %a)@]" - (simple_expr ctxt) e (core_type ctxt) ct - | Pexp_open (o, e) -> - pp f "@[<2>let open%s %a in@;%a@]" - (override o.popen_override) (module_expr ctxt) o.popen_expr - (expression ctxt) e - | Pexp_variant (l,Some eo) -> - pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo - | Pexp_letop {let_; ands; body} -> - pp f "@[<2>@[%a@,%a@] in@;<1 -2>%a@]" - (binding_op ctxt) let_ - (list ~sep:"@," (binding_op ctxt)) ands - (expression ctxt) body - | Pexp_extension e -> extension ctxt f e - | Pexp_unreachable -> pp f "." - | _ -> expression1 ctxt f x - -and expression1 ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs - | _ -> expression2 ctxt f x -(* used in [Pexp_apply] *) - -and expression2 ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_field (e, li) -> - pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li - | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt - - | _ -> simple_expr ctxt f x - -and simple_expr ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_construct _ when is_simple_construct (view_expr x) -> - (match view_expr x with - | `nil -> pp f "[]" - | `tuple -> pp f "()" - | `list xs -> - pp f "@[[%a]@]" - (list (expression (under_semi ctxt)) ~sep:";@;") xs - | `simple x -> longident f x - | _ -> assert false) - | Pexp_ident li -> - longident_loc f li - (* (match view_fixity_of_exp x with *) - (* |`Normal -> longident_loc f li *) - (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) - | Pexp_constant c -> constant f c; - | Pexp_pack me -> - pp f "(module@;%a)" (module_expr ctxt) me - | Pexp_tuple l -> - pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l - | Pexp_constraint (e, ct) -> - pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct - | Pexp_coerce (e, cto1, ct) -> - pp f "(%a%a :> %a)" (expression ctxt) e - (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*) - (core_type ctxt) ct - | Pexp_variant (l, None) -> pp f "`%s" l - | Pexp_record (l, eo) -> - let longident_x_expression f ( li, e) = - match e with - | {pexp_desc=Pexp_ident {txt;_}; - pexp_attributes=[]; _} when li.txt = txt -> - pp f "@[%a@]" longident_loc li - | _ -> - pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e - in - pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) - (option ~last:" with@;" (simple_expr ctxt)) eo - (list longident_x_expression ~sep:";@;") l - | Pexp_array (l) -> - pp f "@[<0>@[<2>[|%a|]@]@]" - (list (simple_expr (under_semi ctxt)) ~sep:";") l - | Pexp_while (e1, e2) -> - let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in - pp f fmt (expression ctxt) e1 (expression ctxt) e2 - | Pexp_for (s, e1, e2, df, e3) -> - let fmt:(_,_,_)format = - "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in - let expression = expression ctxt in - pp f fmt (pattern ctxt) s expression e1 direction_flag - df expression e2 expression e3 - | _ -> paren true (expression ctxt) f x - -and attributes ctxt f l = - List.iter (attribute ctxt f) l - -and item_attributes ctxt f l = - List.iter (item_attribute ctxt f) l - -and attribute ctxt f a = - pp f "@[<2>[@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload - -and item_attribute ctxt f a = - pp f "@[<2>[@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload - -and floating_attribute ctxt f a = - pp f "@[<2>[@@@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload - -and value_description ctxt f x = - (* note: value_description has an attribute field, - but they're already printed by the callers this method *) - pp f "@[%a%a@]" (core_type ctxt) x.pval_type - (fun f x -> - if x.pval_prim <> [] - then pp f "@ =@ %a" (list constant_string) x.pval_prim - ) x - -and extension ctxt f (s, e) = - pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e - -and item_extension ctxt f (s, e) = - pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e - -and exception_declaration ctxt f x = - pp f "@[exception@ %a@]%a" - (extension_constructor ctxt) x.ptyexn_constructor - (item_attributes ctxt) x.ptyexn_attributes - -and class_type_field ctxt f x = - match x.pctf_desc with - | Pctf_inherit (ct) -> - pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_val (s, mf, vf, ct) -> - pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" - mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_method (s, pf, vf, ct) -> - pp f "@[<2>method %a %a%s :@;%a@]%a" - private_flag pf virtual_flag vf s.txt (core_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_constraint (ct1, ct2) -> - pp f "@[<2>constraint@ %a@ =@ %a@]%a" - (core_type ctxt) ct1 (core_type ctxt) ct2 - (item_attributes ctxt) x.pctf_attributes - | Pctf_attribute a -> floating_attribute ctxt f a - | Pctf_extension e -> - item_extension ctxt f e; - item_attributes ctxt f x.pctf_attributes - -and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = - pp f "@[@[object@[<1>%a@]@ %a@]@ end@]" - (fun f -> function - {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> () - | ct -> pp f " (%a)" (core_type ctxt) ct) ct - (list (class_type_field ctxt) ~sep:"@;") l - -(* call [class_signature] called by [class_signature] *) -and class_type ctxt f x = - match x.pcty_desc with - | Pcty_signature cs -> - class_signature ctxt f cs; - attributes ctxt f x.pcty_attributes - | Pcty_constr (li, l) -> - pp f "%a%a%a" - (fun f l -> match l with - | [] -> () - | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l - longident_loc li - (attributes ctxt) x.pcty_attributes - | Pcty_arrow (l, co, cl) -> - pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l,co) - (class_type ctxt) cl - | Pcty_extension e -> - extension ctxt f e; - attributes ctxt f x.pcty_attributes - | Pcty_open (o, e) -> - pp f "@[<2>let open%s %a in@;%a@]" - (override o.popen_override) longident_loc o.popen_expr - (class_type ctxt) e - -(* [class type a = object end] *) -and class_type_declaration_list ctxt f l = - let class_type_declaration kwd f x = - let { pci_params=ls; pci_name={ txt; _ }; _ } = x in - pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd - virtual_flag x.pci_virt - (class_params_def ctxt) ls txt - (class_type ctxt) x.pci_expr - (item_attributes ctxt) x.pci_attributes - in - match l with - | [] -> () - | [x] -> class_type_declaration "class type" f x - | x :: xs -> - pp f "@[%a@,%a@]" - (class_type_declaration "class type") x - (list ~sep:"@," (class_type_declaration "and")) xs - -and class_field ctxt f x = - match x.pcf_desc with - | Pcf_inherit (ovf, ce, so) -> - pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf) - (class_expr ctxt) ce - (fun f so -> match so with - | None -> (); - | Some (s) -> pp f "@ as %s" s.txt ) so - (item_attributes ctxt) x.pcf_attributes - | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> - pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) - mutable_flag mf s.txt - (expression ctxt) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_method (s, pf, Cfk_virtual ct) -> - pp f "@[<2>method virtual %a %s :@;%a@]%a" - private_flag pf s.txt - (core_type ctxt) ct - (item_attributes ctxt) x.pcf_attributes - | Pcf_val (s, mf, Cfk_virtual ct) -> - pp f "@[<2>val virtual %a%s :@ %a@]%a" - mutable_flag mf s.txt - (core_type ctxt) ct - (item_attributes ctxt) x.pcf_attributes - | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> - let bind e = - binding ctxt f - {pvb_pat= - {ppat_desc=Ppat_var s; - ppat_loc=Location.none; - ppat_loc_stack=[]; - ppat_attributes=[]}; - pvb_expr=e; - pvb_constraint=None; - pvb_attributes=[]; - pvb_loc=Location.none; - } - in - pp f "@[<2>method%s %a%a@]%a" - (override ovf) - private_flag pf - (fun f -> function - | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} -> - pp f "%s :@;%a=@;%a" - s.txt (core_type ctxt) ct (expression ctxt) e - | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} -> - bind e - | _ -> bind e) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_constraint (ct1, ct2) -> - pp f "@[<2>constraint %a =@;%a@]%a" - (core_type ctxt) ct1 - (core_type ctxt) ct2 - (item_attributes ctxt) x.pcf_attributes - | Pcf_initializer (e) -> - pp f "@[<2>initializer@ %a@]%a" - (expression ctxt) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_attribute a -> floating_attribute ctxt f a - | Pcf_extension e -> - item_extension ctxt f e; - item_attributes ctxt f x.pcf_attributes - -and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } = - pp f "@[@[object%a@;%a@]@;end@]" - (fun f p -> match p.ppat_desc with - | Ppat_any -> () - | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p - | _ -> pp f " (%a)" (pattern ctxt) p) p - (list (class_field ctxt)) l - -and class_expr ctxt f x = - if x.pcl_attributes <> [] then begin - pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]} - (attributes ctxt) x.pcl_attributes - end else - match x.pcl_desc with - | Pcl_structure (cs) -> class_structure ctxt f cs - | Pcl_fun (l, eo, p, e) -> - pp f "fun@ %a@ ->@ %a" - (label_exp ctxt) (l,eo,p) - (class_expr ctxt) e - | Pcl_let (rf, l, ce) -> - pp f "%a@ in@ %a" - (bindings ctxt) (rf,l) - (class_expr ctxt) ce - | Pcl_apply (ce, l) -> - pp f "((%a)@ %a)" (* Cf: #7200 *) - (class_expr ctxt) ce - (list (label_x_expression_param ctxt)) l - | Pcl_constr (li, l) -> - pp f "%a%a" - (fun f l-> if l <>[] then - pp f "[%a]@ " - (list (core_type ctxt) ~sep:",") l) l - longident_loc li - | Pcl_constraint (ce, ct) -> - pp f "(%a@ :@ %a)" - (class_expr ctxt) ce - (class_type ctxt) ct - | Pcl_extension e -> extension ctxt f e - | Pcl_open (o, e) -> - pp f "@[<2>let open%s %a in@;%a@]" - (override o.popen_override) longident_loc o.popen_expr - (class_expr ctxt) e - -and module_type ctxt f x = - if x.pmty_attributes <> [] then begin - pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]} - (attributes ctxt) x.pmty_attributes - end else - match x.pmty_desc with - | Pmty_functor (Unit, mt2) -> - pp f "@[() ->@ %a@]" (module_type ctxt) mt2 - | Pmty_functor (Named (s, mt1), mt2) -> - begin match s.txt with - | None -> - pp f "@[%a@ ->@ %a@]" - (module_type1 ctxt) mt1 (module_type ctxt) mt2 - | Some name -> - pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" name - (module_type ctxt) mt1 (module_type ctxt) mt2 - end - | Pmty_with (mt, []) -> module_type ctxt f mt - | Pmty_with (mt, l) -> - pp f "@[%a@ with@ %a@]" - (module_type1 ctxt) mt - (list (with_constraint ctxt) ~sep:"@ and@ ") l - | _ -> module_type1 ctxt f x - -and with_constraint ctxt f = function - | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> - pp f "type@ %a %a =@ %a" - (type_params ctxt) ls - longident_loc li (type_declaration ctxt) td - | Pwith_module (li, li2) -> - pp f "module %a =@ %a" longident_loc li longident_loc li2; - | Pwith_modtype (li, mty) -> - pp f "module type %a =@ %a" longident_loc li (module_type ctxt) mty; - | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> - pp f "type@ %a %a :=@ %a" - (type_params ctxt) ls - longident_loc li - (type_declaration ctxt) td - | Pwith_modsubst (li, li2) -> - pp f "module %a :=@ %a" longident_loc li longident_loc li2 - | Pwith_modtypesubst (li, mty) -> - pp f "module type %a :=@ %a" longident_loc li (module_type ctxt) mty; - - -and module_type1 ctxt f x = - if x.pmty_attributes <> [] then module_type ctxt f x - else match x.pmty_desc with - | Pmty_ident li -> - pp f "%a" longident_loc li; - | Pmty_alias li -> - pp f "(module %a)" longident_loc li; - | Pmty_signature (s) -> - pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) - (list (signature_item ctxt)) s (* FIXME wrong indentation*) - | Pmty_typeof me -> - pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me - | Pmty_extension e -> extension ctxt f e - | _ -> paren true (module_type ctxt) f x - -and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x - -and signature_item ctxt f x : unit = - match x.psig_desc with - | Psig_type (rf, l) -> - type_def_list ctxt f (rf, true, l) - | Psig_typesubst l -> - (* Psig_typesubst is never recursive, but we specify [Recursive] here to - avoid printing a [nonrec] flag, which would be rejected by the parser. - *) - type_def_list ctxt f (Recursive, false, l) - | Psig_value vd -> - let intro = if vd.pval_prim = [] then "val" else "external" in - pp f "@[<2>%s@ %a@ :@ %a@]%a" intro - protect_ident vd.pval_name.txt - (value_description ctxt) vd - (item_attributes ctxt) vd.pval_attributes - | Psig_typext te -> - type_extension ctxt f te - | Psig_exception ed -> - exception_declaration ctxt f ed - | Psig_class l -> - let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) = - pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd - virtual_flag x.pci_virt - (class_params_def ctxt) ls txt - (class_type ctxt) x.pci_expr - (item_attributes ctxt) x.pci_attributes - in begin - match l with - | [] -> () - | [x] -> class_description "class" f x - | x :: xs -> - pp f "@[%a@,%a@]" - (class_description "class") x - (list ~sep:"@," (class_description "and")) xs - end - | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias; - pmty_attributes=[]; _};_} as pmd) -> - pp f "@[module@ %s@ =@ %a@]%a" - (Option.value pmd.pmd_name.txt ~default:"_") - longident_loc alias - (item_attributes ctxt) pmd.pmd_attributes - | Psig_module pmd -> - pp f "@[module@ %s@ :@ %a@]%a" - (Option.value pmd.pmd_name.txt ~default:"_") - (module_type ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes - | Psig_modsubst pms -> - pp f "@[module@ %s@ :=@ %a@]%a" pms.pms_name.txt - longident_loc pms.pms_manifest - (item_attributes ctxt) pms.pms_attributes - | Psig_open od -> - pp f "@[open%s@ %a@]%a" - (override od.popen_override) - longident_loc od.popen_expr - (item_attributes ctxt) od.popen_attributes - | Psig_include incl -> - pp f "@[include@ %a@]%a" - (module_type ctxt) incl.pincl_mod - (item_attributes ctxt) incl.pincl_attributes - | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - pp f "@[module@ type@ %s%a@]%a" - s.txt - (fun f md -> match md with - | None -> () - | Some mt -> - pp_print_space f () ; - pp f "@ =@ %a" (module_type ctxt) mt - ) md - (item_attributes ctxt) attrs - | Psig_modtypesubst {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - let md = match md with - | None -> assert false (* ast invariant *) - | Some mt -> mt in - pp f "@[module@ type@ %s@ :=@ %a@]%a" - s.txt (module_type ctxt) md - (item_attributes ctxt) attrs - | Psig_class_type (l) -> class_type_declaration_list ctxt f l - | Psig_recmodule decls -> - let rec string_x_module_type_list f ?(first=true) l = - match l with - | [] -> () ; - | pmd :: tl -> - if not first then - pp f "@ @[and@ %s:@ %a@]%a" - (Option.value pmd.pmd_name.txt ~default:"_") - (module_type1 ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes - else - pp f "@[module@ rec@ %s:@ %a@]%a" - (Option.value pmd.pmd_name.txt ~default:"_") - (module_type1 ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes; - string_x_module_type_list f ~first:false tl - in - string_x_module_type_list f decls - | Psig_attribute a -> floating_attribute ctxt f a - | Psig_extension(e, a) -> - item_extension ctxt f e; - item_attributes ctxt f a - -and module_expr ctxt f x = - if x.pmod_attributes <> [] then - pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]} - (attributes ctxt) x.pmod_attributes - else match x.pmod_desc with - | Pmod_structure (s) -> - pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" - (list (structure_item ctxt) ~sep:"@\n") s; - | Pmod_constraint (me, mt) -> - pp f "@[(%a@ :@ %a)@]" - (module_expr ctxt) me - (module_type ctxt) mt - | Pmod_ident (li) -> - pp f "%a" longident_loc li; - | Pmod_functor (Unit, me) -> - pp f "functor ()@;->@;%a" (module_expr ctxt) me - | Pmod_functor (Named (s, mt), me) -> - pp f "functor@ (%s@ :@ %a)@;->@;%a" - (Option.value s.txt ~default:"_") - (module_type ctxt) mt (module_expr ctxt) me - | Pmod_apply (me1, me2) -> - pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 - (* Cf: #7200 *) - | Pmod_apply_unit me1 -> - pp f "(%a)()" (module_expr ctxt) me1 - | Pmod_unpack e -> - pp f "(val@ %a)" (expression ctxt) e - | Pmod_extension e -> extension ctxt f e - -and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x - -and payload ctxt f = function - | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> - pp f "@[<2>%a@]%a" - (expression ctxt) e - (item_attributes ctxt) attrs - | PStr x -> structure ctxt f x - | PTyp x -> pp f ":@ "; core_type ctxt f x - | PSig x -> pp f ":@ "; signature ctxt f x - | PPat (x, None) -> pp f "?@ "; pattern ctxt f x - | PPat (x, Some e) -> - pp f "?@ "; pattern ctxt f x; - pp f " when "; expression ctxt f e - -(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) -and binding ctxt f {pvb_pat=p; pvb_expr=x; pvb_constraint = ct; _} = - (* .pvb_attributes have already been printed by the caller, #bindings *) - let rec pp_print_pexp_function f x = - if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x - else match x.pexp_desc with - | Pexp_fun (label, eo, p, e) -> - if label=Nolabel then - pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e - else - pp f "%a@ %a" - (label_exp ctxt) (label,eo,p) pp_print_pexp_function e - | Pexp_newtype (str,e) -> - pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e - | _ -> pp f "=@;%a" (expression ctxt) x - in - match ct with - | Some (Pvc_constraint { locally_abstract_univars = []; typ }) -> - pp f "%a@;:@;%a@;=@;%a" - (simple_pattern ctxt) p (core_type ctxt) typ (expression ctxt) x - | Some (Pvc_constraint { locally_abstract_univars = vars; typ }) -> - pp f "%a@;: type@;%a.@;%a@;=@;%a" - (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") - (List.map (fun x -> x.txt) vars) - (core_type ctxt) typ (expression ctxt) x - | Some (Pvc_coercion {ground=None; coercion }) -> - pp f "%a@;:>@;%a@;=@;%a" - (simple_pattern ctxt) p (core_type ctxt) coercion (expression ctxt) x - | Some (Pvc_coercion {ground=Some ground; coercion }) -> - pp f "%a@;:%a@;:>@;%a@;=@;%a" - (simple_pattern ctxt) p - (core_type ctxt) ground - (core_type ctxt) coercion - (expression ctxt) x - | None -> begin - match p with - | {ppat_desc=Ppat_var _; ppat_attributes=[]} -> - pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x - | _ -> - pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x - end - -(* [in] is not printed *) -and bindings ctxt f (rf,l) = - let binding kwd rf f x = - pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf - (binding ctxt) x (item_attributes ctxt) x.pvb_attributes - in - match l with - | [] -> () - | [x] -> binding "let" rf f x - | x::xs -> - pp f "@[%a@,%a@]" - (binding "let" rf) x - (list ~sep:"@," (binding "and" Nonrecursive)) xs - -and binding_op ctxt f x = - match x.pbop_pat, x.pbop_exp with - | {ppat_desc = Ppat_var { txt=pvar; _ }; ppat_attributes = []; _}, - {pexp_desc = Pexp_ident { txt=Lident evar; _}; pexp_attributes = []; _} - when pvar = evar -> - pp f "@[<2>%s %s@]" x.pbop_op.txt evar - | pat, exp -> - pp f "@[<2>%s %a@;=@;%a@]" - x.pbop_op.txt (pattern ctxt) pat (expression ctxt) exp - -and structure_item ctxt f x = - match x.pstr_desc with - | Pstr_eval (e, attrs) -> - pp f "@[;;%a@]%a" - (expression ctxt) e - (item_attributes ctxt) attrs - | Pstr_type (_, []) -> assert false - | Pstr_type (rf, l) -> type_def_list ctxt f (rf, true, l) - | Pstr_value (rf, l) -> - (* pp f "@[let %a%a@]" rec_flag rf bindings l *) - pp f "@[<2>%a@]" (bindings ctxt) (rf,l) - | Pstr_typext te -> type_extension ctxt f te - | Pstr_exception ed -> exception_declaration ctxt f ed - | Pstr_module x -> - let rec module_helper = function - | {pmod_desc=Pmod_functor(arg_opt,me'); pmod_attributes = []} -> - begin match arg_opt with - | Unit -> pp f "()" - | Named (s, mt) -> - pp f "(%s:%a)" (Option.value s.txt ~default:"_") - (module_type ctxt) mt - end; - module_helper me' - | me -> me - in - pp f "@[module %s%a@]%a" - (Option.value x.pmb_name.txt ~default:"_") - (fun f me -> - let me = module_helper me in - match me with - | {pmod_desc= - Pmod_constraint - (me', - ({pmty_desc=(Pmty_ident (_) - | Pmty_signature (_));_} as mt)); - pmod_attributes = []} -> - pp f " :@;%a@;=@;%a@;" - (module_type ctxt) mt (module_expr ctxt) me' - | _ -> pp f " =@ %a" (module_expr ctxt) me - ) x.pmb_expr - (item_attributes ctxt) x.pmb_attributes - | Pstr_open od -> - pp f "@[<2>open%s@;%a@]%a" - (override od.popen_override) - (module_expr ctxt) od.popen_expr - (item_attributes ctxt) od.popen_attributes - | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - pp f "@[module@ type@ %s%a@]%a" - s.txt - (fun f md -> match md with - | None -> () - | Some mt -> - pp_print_space f () ; - pp f "@ =@ %a" (module_type ctxt) mt - ) md - (item_attributes ctxt) attrs - | Pstr_class l -> - let extract_class_args cl = - let rec loop acc = function - | {pcl_desc=Pcl_fun (l, eo, p, cl'); pcl_attributes = []} -> - loop ((l,eo,p) :: acc) cl' - | cl -> List.rev acc, cl - in - let args, cl = loop [] cl in - let constr, cl = - match cl with - | {pcl_desc=Pcl_constraint (cl', ct); pcl_attributes = []} -> - Some ct, cl' - | _ -> None, cl - in - args, constr, cl - in - let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in - let class_declaration kwd f - ({pci_params=ls; pci_name={txt;_}; _} as x) = - let args, constr, cl = extract_class_args x.pci_expr in - pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd - virtual_flag x.pci_virt - (class_params_def ctxt) ls txt - (list (label_exp ctxt)) args - (option class_constraint) constr - (class_expr ctxt) cl - (item_attributes ctxt) x.pci_attributes - in begin - match l with - | [] -> () - | [x] -> class_declaration "class" f x - | x :: xs -> - pp f "@[%a@,%a@]" - (class_declaration "class") x - (list ~sep:"@," (class_declaration "and")) xs - end - | Pstr_class_type l -> class_type_declaration_list ctxt f l - | Pstr_primitive vd -> - pp f "@[external@ %a@ :@ %a@]%a" - protect_ident vd.pval_name.txt - (value_description ctxt) vd - (item_attributes ctxt) vd.pval_attributes - | Pstr_include incl -> - pp f "@[include@ %a@]%a" - (module_expr ctxt) incl.pincl_mod - (item_attributes ctxt) incl.pincl_attributes - | Pstr_recmodule decls -> (* 3.07 *) - let aux f = function - | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> - pp f "@[@ and@ %s:%a@ =@ %a@]%a" - (Option.value pmb.pmb_name.txt ~default:"_") - (module_type ctxt) typ - (module_expr ctxt) expr - (item_attributes ctxt) pmb.pmb_attributes - | pmb -> - pp f "@[@ and@ %s@ =@ %a@]%a" - (Option.value pmb.pmb_name.txt ~default:"_") - (module_expr ctxt) pmb.pmb_expr - (item_attributes ctxt) pmb.pmb_attributes - in - begin match decls with - | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> - pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" - (Option.value pmb.pmb_name.txt ~default:"_") - (module_type ctxt) typ - (module_expr ctxt) expr - (item_attributes ctxt) pmb.pmb_attributes - (fun f l2 -> List.iter (aux f) l2) l2 - | pmb :: l2 -> - pp f "@[@[module@ rec@ %s@ =@ %a@]%a@ %a@]" - (Option.value pmb.pmb_name.txt ~default:"_") - (module_expr ctxt) pmb.pmb_expr - (item_attributes ctxt) pmb.pmb_attributes - (fun f l2 -> List.iter (aux f) l2) l2 - | _ -> assert false - end - | Pstr_attribute a -> floating_attribute ctxt f a - | Pstr_extension(e, a) -> - item_extension ctxt f e; - item_attributes ctxt f a - -and type_param ctxt f (ct, (a,b)) = - pp f "%s%s%a" (type_variance a) (type_injectivity b) (core_type ctxt) ct - -and type_params ctxt f = function - | [] -> () - | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l - -and type_def_list ctxt f (rf, exported, l) = - let type_decl kwd rf f x = - let eq = - if (x.ptype_kind = Ptype_abstract) - && (x.ptype_manifest = None) then "" - else if exported then " =" - else " :=" - in - pp f "@[<2>%s %a%a%s%s%a@]%a" kwd - nonrec_flag rf - (type_params ctxt) x.ptype_params - x.ptype_name.txt eq - (type_declaration ctxt) x - (item_attributes ctxt) x.ptype_attributes - in - match l with - | [] -> assert false - | [x] -> type_decl "type" rf f x - | x :: xs -> pp f "@[%a@,%a@]" - (type_decl "type" rf) x - (list ~sep:"@," (type_decl "and" Recursive)) xs - -and record_declaration ctxt f lbls = - let type_record_field f pld = - pp f "@[<2>%a%s:@;%a@;%a@]" - mutable_flag pld.pld_mutable - pld.pld_name.txt - (core_type ctxt) pld.pld_type - (attributes ctxt) pld.pld_attributes - in - pp f "{@\n%a}" - (list type_record_field ~sep:";@\n" ) lbls - -and type_declaration ctxt f x = - (* type_declaration has an attribute field, - but it's been printed by the caller of this method *) - let priv f = - match x.ptype_private with - | Public -> () - | Private -> pp f "@;private" - in - let manifest f = - match x.ptype_manifest with - | None -> () - | Some y -> - if x.ptype_kind = Ptype_abstract then - pp f "%t@;%a" priv (core_type ctxt) y - else - pp f "@;%a" (core_type ctxt) y - in - let constructor_declaration f pcd = - pp f "|@;"; - constructor_declaration ctxt f - (pcd.pcd_name.txt, pcd.pcd_vars, - pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) - in - let repr f = - let intro f = - if x.ptype_manifest = None then () - else pp f "@;=" - in - match x.ptype_kind with - | Ptype_variant xs -> - let variants fmt xs = - if xs = [] then pp fmt " |" else - pp fmt "@\n%a" (list ~sep:"@\n" constructor_declaration) xs - in pp f "%t%t%a" intro priv variants xs - | Ptype_abstract -> () - | Ptype_record l -> - pp f "%t%t@;%a" intro priv (record_declaration ctxt) l - | Ptype_open -> pp f "%t%t@;.." intro priv - in - let constraints f = - List.iter - (fun (ct1,ct2,_) -> - pp f "@[@ constraint@ %a@ =@ %a@]" - (core_type ctxt) ct1 (core_type ctxt) ct2) - x.ptype_cstrs - in - pp f "%t%t%t" manifest repr constraints - -and type_extension ctxt f x = - let extension_constructor f x = - pp f "@\n|@;%a" (extension_constructor ctxt) x - in - pp f "@[<2>type %a%a += %a@ %a@]%a" - (fun f -> function - | [] -> () - | l -> - pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) - x.ptyext_params - longident_loc x.ptyext_path - private_flag x.ptyext_private (* Cf: #7200 *) - (list ~sep:"" extension_constructor) - x.ptyext_constructors - (item_attributes ctxt) x.ptyext_attributes - -and constructor_declaration ctxt f (name, vars, args, res, attrs) = - let name = - match name with - | "::" -> "(::)" - | s -> s in - let pp_vars f vs = - match vs with - | [] -> () - | vs -> pp f "%a@;.@;" (list tyvar_loc ~sep:"@;") vs in - match res with - | None -> - pp f "%s%a@;%a" name - (fun f -> function - | Pcstr_tuple [] -> () - | Pcstr_tuple l -> - pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l - | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l - ) args - (attributes ctxt) attrs - | Some r -> - pp f "%s:@;%a%a@;%a" name - pp_vars vars - (fun f -> function - | Pcstr_tuple [] -> core_type1 ctxt f r - | Pcstr_tuple l -> pp f "%a@;->@;%a" - (list (core_type1 ctxt) ~sep:"@;*@;") l - (core_type1 ctxt) r - | Pcstr_record l -> - pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r - ) - args - (attributes ctxt) attrs - -and extension_constructor ctxt f x = - (* Cf: #7200 *) - match x.pext_kind with - | Pext_decl(v, l, r) -> - constructor_declaration ctxt f - (x.pext_name.txt, v, l, r, x.pext_attributes) - | Pext_rebind li -> - pp f "%s@;=@;%a%a" x.pext_name.txt - longident_loc li - (attributes ctxt) x.pext_attributes - -and case_list ctxt f l : unit = - let aux f {pc_lhs; pc_guard; pc_rhs} = - pp f "@;| @[<2>%a%a@;->@;%a@]" - (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;") - pc_guard (expression (under_pipe ctxt)) pc_rhs - in - list aux f l ~sep:"" - -and label_x_expression_param ctxt f (l,e) = - let simple_name = match e with - | {pexp_desc=Pexp_ident {txt=Lident l;_}; - pexp_attributes=[]} -> Some l - | _ -> None - in match l with - | Nolabel -> expression2 ctxt f e (* level 2*) - | Optional str -> - if Some str = simple_name then - pp f "?%s" str - else - pp f "?%s:%a" str (simple_expr ctxt) e - | Labelled lbl -> - if Some lbl = simple_name then - pp f "~%s" lbl - else - pp f "~%s:%a" lbl (simple_expr ctxt) e - -and directive_argument f x = - match x.pdira_desc with - | Pdir_string (s) -> pp f "@ %S" s - | Pdir_int (n, None) -> pp f "@ %s" n - | Pdir_int (n, Some m) -> pp f "@ %s%c" n m - | Pdir_ident (li) -> pp f "@ %a" longident li - | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b) - -let toplevel_phrase f x = - match x with - | Ptop_def (s) ->pp f "@[%a@]" (list (structure_item reset_ctxt)) s - (* pp_open_hvbox f 0; *) - (* pp_print_list structure_item f s ; *) - (* pp_close_box f (); *) - | Ptop_dir {pdir_name; pdir_arg = None; _} -> - pp f "@[#%s@]" pdir_name.txt - | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} -> - pp f "@[#%s@ %a@]" pdir_name.txt directive_argument pdir_arg - -let expression f x = - pp f "@[%a@]" (expression reset_ctxt) x - -let string_of_expression x = - ignore (flush_str_formatter ()) ; - let f = str_formatter in - expression f x; - flush_str_formatter () - -let string_of_structure x = - ignore (flush_str_formatter ()); - let f = str_formatter in - structure reset_ctxt f x; - flush_str_formatter () - -let top_phrase f x = - pp_print_newline f (); - toplevel_phrase f x; - pp f ";;"; - pp_print_newline f () - -let core_type = core_type reset_ctxt -let pattern = pattern reset_ctxt -let signature = signature reset_ctxt -let structure = structure reset_ctxt -let module_expr = module_expr reset_ctxt -let module_type = module_type reset_ctxt -let class_field = class_field reset_ctxt -let class_type_field = class_type_field reset_ctxt -let class_expr = class_expr reset_ctxt -let class_type = class_type reset_ctxt -let structure_item = structure_item reset_ctxt -let signature_item = signature_item reset_ctxt -let binding = binding reset_ctxt -let payload = payload reset_ctxt diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli deleted file mode 100644 index 42acd5f15c..0000000000 --- a/parsing/pprintast.mli +++ /dev/null @@ -1,55 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Hongbo Zhang (University of Pennsylvania) *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - - -(** Pretty-printers for {!Parsetree} - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -type space_formatter = (unit, Format.formatter, unit) format - -val longident : Format.formatter -> Longident.t -> unit -val expression : Format.formatter -> Parsetree.expression -> unit -val string_of_expression : Parsetree.expression -> string - -val pattern: Format.formatter -> Parsetree.pattern -> unit - -val core_type: Format.formatter -> Parsetree.core_type -> unit - -val signature: Format.formatter -> Parsetree.signature -> unit -val structure: Format.formatter -> Parsetree.structure -> unit -val string_of_structure: Parsetree.structure -> string - -val module_expr: Format.formatter -> Parsetree.module_expr -> unit - -val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit -val top_phrase: Format.formatter -> Parsetree.toplevel_phrase -> unit - -val class_field: Format.formatter -> Parsetree.class_field -> unit -val class_type_field: Format.formatter -> Parsetree.class_type_field -> unit -val class_expr: Format.formatter -> Parsetree.class_expr -> unit -val class_type: Format.formatter -> Parsetree.class_type -> unit -val module_type: Format.formatter -> Parsetree.module_type -> unit -val structure_item: Format.formatter -> Parsetree.structure_item -> unit -val signature_item: Format.formatter -> Parsetree.signature_item -> unit -val binding: Format.formatter -> Parsetree.value_binding -> unit -val payload: Format.formatter -> Parsetree.payload -> unit - -val tyvar: Format.formatter -> string -> unit - (** Print a type variable name, taking care of the special treatment - required for the single quote character in second position. *) diff --git a/parsing/printast.ml b/parsing/printast.ml deleted file mode 100644 index cdca427060..0000000000 --- a/parsing/printast.ml +++ /dev/null @@ -1,982 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Damien Doligez, projet Para, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Asttypes -open Format -open Lexing -open Location -open Parsetree - -let fmt_position with_name f l = - let fname = if with_name then l.pos_fname else "" in - if l.pos_lnum = -1 - then fprintf f "%s[%d]" fname l.pos_cnum - else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol - (l.pos_cnum - l.pos_bol) - -let fmt_location f loc = - if not !Clflags.locations then () - else begin - let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in - fprintf f "(%a..%a)" (fmt_position true) loc.loc_start - (fmt_position p_2nd_name) loc.loc_end; - if loc.loc_ghost then fprintf f " ghost"; - end - -let rec fmt_longident_aux f x = - match x with - | Longident.Lident (s) -> fprintf f "%s" s - | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s - | Longident.Lapply (y, z) -> - fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z - -let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x - -let fmt_longident_loc f (x : Longident.t loc) = - fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc - -let fmt_string_loc f (x : string loc) = - fprintf f "\"%s\" %a" x.txt fmt_location x.loc - -let fmt_str_opt_loc f (x : string option loc) = - fprintf f "\"%s\" %a" (Option.value x.txt ~default:"_") fmt_location x.loc - -let fmt_char_option f = function - | None -> fprintf f "None" - | Some c -> fprintf f "Some %c" c - -let fmt_constant f x = - match x with - | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m - | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c) - | Pconst_string (s, strloc, None) -> - fprintf f "PConst_string(%S,%a,None)" s fmt_location strloc - | Pconst_string (s, strloc, Some delim) -> - fprintf f "PConst_string (%S,%a,Some %S)" s fmt_location strloc delim - | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m - -let fmt_mutable_flag f x = - match x with - | Immutable -> fprintf f "Immutable" - | Mutable -> fprintf f "Mutable" - -let fmt_virtual_flag f x = - match x with - | Virtual -> fprintf f "Virtual" - | Concrete -> fprintf f "Concrete" - -let fmt_override_flag f x = - match x with - | Override -> fprintf f "Override" - | Fresh -> fprintf f "Fresh" - -let fmt_closed_flag f x = - match x with - | Closed -> fprintf f "Closed" - | Open -> fprintf f "Open" - -let fmt_rec_flag f x = - match x with - | Nonrecursive -> fprintf f "Nonrec" - | Recursive -> fprintf f "Rec" - -let fmt_direction_flag f x = - match x with - | Upto -> fprintf f "Up" - | Downto -> fprintf f "Down" - -let fmt_private_flag f x = - match x with - | Public -> fprintf f "Public" - | Private -> fprintf f "Private" - -let line i f s (*...*) = - fprintf f "%s" (String.make ((2*i) mod 72) ' '); - fprintf f s (*...*) - -let list i f ppf l = - match l with - | [] -> line i ppf "[]\n" - | _ :: _ -> - line i ppf "[\n"; - List.iter (f (i+1) ppf) l; - line i ppf "]\n" - -let option i f ppf x = - match x with - | None -> line i ppf "None\n" - | Some x -> - line i ppf "Some\n"; - f (i+1) ppf x - -let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li -let string i ppf s = line i ppf "\"%s\"\n" s -let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s -let str_opt_loc i ppf s = line i ppf "%a\n" fmt_str_opt_loc s -let arg_label i ppf = function - | Nolabel -> line i ppf "Nolabel\n" - | Optional s -> line i ppf "Optional \"%s\"\n" s - | Labelled s -> line i ppf "Labelled \"%s\"\n" s - -let typevars ppf vs = - List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs - -let rec core_type i ppf x = - line i ppf "core_type %a\n" fmt_location x.ptyp_loc; - attributes i ppf x.ptyp_attributes; - let i = i+1 in - match x.ptyp_desc with - | Ptyp_any -> line i ppf "Ptyp_any\n"; - | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s; - | Ptyp_arrow (l, ct1, ct2) -> - line i ppf "Ptyp_arrow\n"; - arg_label i ppf l; - core_type i ppf ct1; - core_type i ppf ct2; - | Ptyp_tuple l -> - line i ppf "Ptyp_tuple\n"; - list i core_type ppf l; - | Ptyp_constr (li, l) -> - line i ppf "Ptyp_constr %a\n" fmt_longident_loc li; - list i core_type ppf l; - | Ptyp_variant (l, closed, low) -> - line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed; - list i label_x_bool_x_core_type_list ppf l; - option i (fun i -> list i string) ppf low - | Ptyp_object (l, c) -> - line i ppf "Ptyp_object %a\n" fmt_closed_flag c; - let i = i + 1 in - List.iter (fun field -> - match field.pof_desc with - | Otag (l, t) -> - line i ppf "method %s\n" l.txt; - attributes i ppf field.pof_attributes; - core_type (i + 1) ppf t - | Oinherit ct -> - line i ppf "Oinherit\n"; - core_type (i + 1) ppf ct - ) l - | Ptyp_class (li, l) -> - line i ppf "Ptyp_class %a\n" fmt_longident_loc li; - list i core_type ppf l - | Ptyp_alias (ct, s) -> - line i ppf "Ptyp_alias \"%s\"\n" s; - core_type i ppf ct; - | Ptyp_poly (sl, ct) -> - line i ppf "Ptyp_poly%a\n" typevars sl; - core_type i ppf ct; - | Ptyp_package (s, l) -> - line i ppf "Ptyp_package %a\n" fmt_longident_loc s; - list i package_with ppf l; - | Ptyp_extension (s, arg) -> - line i ppf "Ptyp_extension \"%s\"\n" s.txt; - payload i ppf arg - -and package_with i ppf (s, t) = - line i ppf "with type %a\n" fmt_longident_loc s; - core_type i ppf t - -and pattern i ppf x = - line i ppf "pattern %a\n" fmt_location x.ppat_loc; - attributes i ppf x.ppat_attributes; - let i = i+1 in - match x.ppat_desc with - | Ppat_any -> line i ppf "Ppat_any\n"; - | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s; - | Ppat_alias (p, s) -> - line i ppf "Ppat_alias %a\n" fmt_string_loc s; - pattern i ppf p; - | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; - | Ppat_interval (c1, c2) -> - line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2; - | Ppat_tuple (l) -> - line i ppf "Ppat_tuple\n"; - list i pattern ppf l; - | Ppat_construct (li, po) -> - line i ppf "Ppat_construct %a\n" fmt_longident_loc li; - option i - (fun i ppf (vl, p) -> - list i string_loc ppf vl; - pattern i ppf p) - ppf po - | Ppat_variant (l, po) -> - line i ppf "Ppat_variant \"%s\"\n" l; - option i pattern ppf po; - | Ppat_record (l, c) -> - line i ppf "Ppat_record %a\n" fmt_closed_flag c; - list i longident_x_pattern ppf l; - | Ppat_array (l) -> - line i ppf "Ppat_array\n"; - list i pattern ppf l; - | Ppat_or (p1, p2) -> - line i ppf "Ppat_or\n"; - pattern i ppf p1; - pattern i ppf p2; - | Ppat_lazy p -> - line i ppf "Ppat_lazy\n"; - pattern i ppf p; - | Ppat_constraint (p, ct) -> - line i ppf "Ppat_constraint\n"; - pattern i ppf p; - core_type i ppf ct; - | Ppat_type (li) -> - line i ppf "Ppat_type\n"; - longident_loc i ppf li - | Ppat_unpack s -> - line i ppf "Ppat_unpack %a\n" fmt_str_opt_loc s; - | Ppat_exception p -> - line i ppf "Ppat_exception\n"; - pattern i ppf p - | Ppat_open (m,p) -> - line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m; - pattern i ppf p - | Ppat_extension (s, arg) -> - line i ppf "Ppat_extension \"%s\"\n" s.txt; - payload i ppf arg - -and expression i ppf x = - line i ppf "expression %a\n" fmt_location x.pexp_loc; - attributes i ppf x.pexp_attributes; - let i = i+1 in - match x.pexp_desc with - | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li; - | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; - | Pexp_let (rf, l, e) -> - line i ppf "Pexp_let %a\n" fmt_rec_flag rf; - list i value_binding ppf l; - expression i ppf e; - | Pexp_function l -> - line i ppf "Pexp_function\n"; - list i case ppf l; - | Pexp_fun (l, eo, p, e) -> - line i ppf "Pexp_fun\n"; - arg_label i ppf l; - option i expression ppf eo; - pattern i ppf p; - expression i ppf e; - | Pexp_apply (e, l) -> - line i ppf "Pexp_apply\n"; - expression i ppf e; - list i label_x_expression ppf l; - | Pexp_match (e, l) -> - line i ppf "Pexp_match\n"; - expression i ppf e; - list i case ppf l; - | Pexp_try (e, l) -> - line i ppf "Pexp_try\n"; - expression i ppf e; - list i case ppf l; - | Pexp_tuple (l) -> - line i ppf "Pexp_tuple\n"; - list i expression ppf l; - | Pexp_construct (li, eo) -> - line i ppf "Pexp_construct %a\n" fmt_longident_loc li; - option i expression ppf eo; - | Pexp_variant (l, eo) -> - line i ppf "Pexp_variant \"%s\"\n" l; - option i expression ppf eo; - | Pexp_record (l, eo) -> - line i ppf "Pexp_record\n"; - list i longident_x_expression ppf l; - option i expression ppf eo; - | Pexp_field (e, li) -> - line i ppf "Pexp_field\n"; - expression i ppf e; - longident_loc i ppf li; - | Pexp_setfield (e1, li, e2) -> - line i ppf "Pexp_setfield\n"; - expression i ppf e1; - longident_loc i ppf li; - expression i ppf e2; - | Pexp_array (l) -> - line i ppf "Pexp_array\n"; - list i expression ppf l; - | Pexp_ifthenelse (e1, e2, eo) -> - line i ppf "Pexp_ifthenelse\n"; - expression i ppf e1; - expression i ppf e2; - option i expression ppf eo; - | Pexp_sequence (e1, e2) -> - line i ppf "Pexp_sequence\n"; - expression i ppf e1; - expression i ppf e2; - | Pexp_while (e1, e2) -> - line i ppf "Pexp_while\n"; - expression i ppf e1; - expression i ppf e2; - | Pexp_for (p, e1, e2, df, e3) -> - line i ppf "Pexp_for %a\n" fmt_direction_flag df; - pattern i ppf p; - expression i ppf e1; - expression i ppf e2; - expression i ppf e3; - | Pexp_constraint (e, ct) -> - line i ppf "Pexp_constraint\n"; - expression i ppf e; - core_type i ppf ct; - | Pexp_coerce (e, cto1, cto2) -> - line i ppf "Pexp_coerce\n"; - expression i ppf e; - option i core_type ppf cto1; - core_type i ppf cto2; - | Pexp_send (e, s) -> - line i ppf "Pexp_send \"%s\"\n" s.txt; - expression i ppf e; - | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li; - | Pexp_setinstvar (s, e) -> - line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s; - expression i ppf e; - | Pexp_override (l) -> - line i ppf "Pexp_override\n"; - list i string_x_expression ppf l; - | Pexp_letmodule (s, me, e) -> - line i ppf "Pexp_letmodule %a\n" fmt_str_opt_loc s; - module_expr i ppf me; - expression i ppf e; - | Pexp_letexception (cd, e) -> - line i ppf "Pexp_letexception\n"; - extension_constructor i ppf cd; - expression i ppf e; - | Pexp_assert (e) -> - line i ppf "Pexp_assert\n"; - expression i ppf e; - | Pexp_lazy (e) -> - line i ppf "Pexp_lazy\n"; - expression i ppf e; - | Pexp_poly (e, cto) -> - line i ppf "Pexp_poly\n"; - expression i ppf e; - option i core_type ppf cto; - | Pexp_object s -> - line i ppf "Pexp_object\n"; - class_structure i ppf s - | Pexp_newtype (s, e) -> - line i ppf "Pexp_newtype \"%s\"\n" s.txt; - expression i ppf e - | Pexp_pack me -> - line i ppf "Pexp_pack\n"; - module_expr i ppf me - | Pexp_open (o, e) -> - line i ppf "Pexp_open %a\n" fmt_override_flag o.popen_override; - module_expr i ppf o.popen_expr; - expression i ppf e - | Pexp_letop {let_; ands; body} -> - line i ppf "Pexp_letop\n"; - binding_op i ppf let_; - list i binding_op ppf ands; - expression i ppf body - | Pexp_extension (s, arg) -> - line i ppf "Pexp_extension \"%s\"\n" s.txt; - payload i ppf arg - | Pexp_unreachable -> - line i ppf "Pexp_unreachable" - -and value_description i ppf x = - line i ppf "value_description %a %a\n" fmt_string_loc - x.pval_name fmt_location x.pval_loc; - attributes i ppf x.pval_attributes; - core_type (i+1) ppf x.pval_type; - list (i+1) string ppf x.pval_prim - -and type_parameter i ppf (x, _variance) = core_type i ppf x - -and type_declaration i ppf x = - line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name - fmt_location x.ptype_loc; - attributes i ppf x.ptype_attributes; - let i = i+1 in - line i ppf "ptype_params =\n"; - list (i+1) type_parameter ppf x.ptype_params; - line i ppf "ptype_cstrs =\n"; - list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs; - line i ppf "ptype_kind =\n"; - type_kind (i+1) ppf x.ptype_kind; - line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; - line i ppf "ptype_manifest =\n"; - option (i+1) core_type ppf x.ptype_manifest - -and attribute i ppf k a = - line i ppf "%s \"%s\"\n" k a.attr_name.txt; - payload i ppf a.attr_payload; - -and attributes i ppf l = - let i = i + 1 in - List.iter (fun a -> - line i ppf "attribute \"%s\"\n" a.attr_name.txt; - payload (i + 1) ppf a.attr_payload; - ) l; - -and payload i ppf = function - | PStr x -> structure i ppf x - | PSig x -> signature i ppf x - | PTyp x -> core_type i ppf x - | PPat (x, None) -> pattern i ppf x - | PPat (x, Some g) -> - pattern i ppf x; - line i ppf "\n"; - expression (i + 1) ppf g - - -and type_kind i ppf x = - match x with - | Ptype_abstract -> - line i ppf "Ptype_abstract\n" - | Ptype_variant l -> - line i ppf "Ptype_variant\n"; - list (i+1) constructor_decl ppf l; - | Ptype_record l -> - line i ppf "Ptype_record\n"; - list (i+1) label_decl ppf l; - | Ptype_open -> - line i ppf "Ptype_open\n"; - -and type_extension i ppf x = - line i ppf "type_extension\n"; - attributes i ppf x.ptyext_attributes; - let i = i+1 in - line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path; - line i ppf "ptyext_params =\n"; - list (i+1) type_parameter ppf x.ptyext_params; - line i ppf "ptyext_constructors =\n"; - list (i+1) extension_constructor ppf x.ptyext_constructors; - line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private; - -and type_exception i ppf x = - line i ppf "type_exception\n"; - attributes i ppf x.ptyexn_attributes; - let i = i+1 in - line i ppf "ptyext_constructor =\n"; - let i = i+1 in - extension_constructor i ppf x.ptyexn_constructor - -and extension_constructor i ppf x = - line i ppf "extension_constructor %a\n" fmt_location x.pext_loc; - attributes i ppf x.pext_attributes; - let i = i + 1 in - line i ppf "pext_name = \"%s\"\n" x.pext_name.txt; - line i ppf "pext_kind =\n"; - extension_constructor_kind (i + 1) ppf x.pext_kind; - -and extension_constructor_kind i ppf x = - match x with - Pext_decl(v, a, r) -> - line i ppf "Pext_decl\n"; - if v <> [] then line (i+1) ppf "vars%a\n" typevars v; - constructor_arguments (i+1) ppf a; - option (i+1) core_type ppf r; - | Pext_rebind li -> - line i ppf "Pext_rebind\n"; - line (i+1) ppf "%a\n" fmt_longident_loc li; - -and class_type i ppf x = - line i ppf "class_type %a\n" fmt_location x.pcty_loc; - attributes i ppf x.pcty_attributes; - let i = i+1 in - match x.pcty_desc with - | Pcty_constr (li, l) -> - line i ppf "Pcty_constr %a\n" fmt_longident_loc li; - list i core_type ppf l; - | Pcty_signature (cs) -> - line i ppf "Pcty_signature\n"; - class_signature i ppf cs; - | Pcty_arrow (l, co, cl) -> - line i ppf "Pcty_arrow\n"; - arg_label i ppf l; - core_type i ppf co; - class_type i ppf cl; - | Pcty_extension (s, arg) -> - line i ppf "Pcty_extension \"%s\"\n" s.txt; - payload i ppf arg - | Pcty_open (o, e) -> - line i ppf "Pcty_open %a %a\n" fmt_override_flag o.popen_override - fmt_longident_loc o.popen_expr; - class_type i ppf e - -and class_signature i ppf cs = - line i ppf "class_signature\n"; - core_type (i+1) ppf cs.pcsig_self; - list (i+1) class_type_field ppf cs.pcsig_fields; - -and class_type_field i ppf x = - line i ppf "class_type_field %a\n" fmt_location x.pctf_loc; - let i = i+1 in - attributes i ppf x.pctf_attributes; - match x.pctf_desc with - | Pctf_inherit (ct) -> - line i ppf "Pctf_inherit\n"; - class_type i ppf ct; - | Pctf_val (s, mf, vf, ct) -> - line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf - fmt_virtual_flag vf; - core_type (i+1) ppf ct; - | Pctf_method (s, pf, vf, ct) -> - line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf - fmt_virtual_flag vf; - core_type (i+1) ppf ct; - | Pctf_constraint (ct1, ct2) -> - line i ppf "Pctf_constraint\n"; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; - | Pctf_attribute a -> - attribute i ppf "Pctf_attribute" a - | Pctf_extension (s, arg) -> - line i ppf "Pctf_extension \"%s\"\n" s.txt; - payload i ppf arg - -and class_description i ppf x = - line i ppf "class_description %a\n" fmt_location x.pci_loc; - attributes i ppf x.pci_attributes; - let i = i+1 in - line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; - line i ppf "pci_params =\n"; - list (i+1) type_parameter ppf x.pci_params; - line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; - line i ppf "pci_expr =\n"; - class_type (i+1) ppf x.pci_expr; - -and class_type_declaration i ppf x = - line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc; - attributes i ppf x.pci_attributes; - let i = i+1 in - line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; - line i ppf "pci_params =\n"; - list (i+1) type_parameter ppf x.pci_params; - line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; - line i ppf "pci_expr =\n"; - class_type (i+1) ppf x.pci_expr; - -and class_expr i ppf x = - line i ppf "class_expr %a\n" fmt_location x.pcl_loc; - attributes i ppf x.pcl_attributes; - let i = i+1 in - match x.pcl_desc with - | Pcl_constr (li, l) -> - line i ppf "Pcl_constr %a\n" fmt_longident_loc li; - list i core_type ppf l; - | Pcl_structure (cs) -> - line i ppf "Pcl_structure\n"; - class_structure i ppf cs; - | Pcl_fun (l, eo, p, e) -> - line i ppf "Pcl_fun\n"; - arg_label i ppf l; - option i expression ppf eo; - pattern i ppf p; - class_expr i ppf e; - | Pcl_apply (ce, l) -> - line i ppf "Pcl_apply\n"; - class_expr i ppf ce; - list i label_x_expression ppf l; - | Pcl_let (rf, l, ce) -> - line i ppf "Pcl_let %a\n" fmt_rec_flag rf; - list i value_binding ppf l; - class_expr i ppf ce; - | Pcl_constraint (ce, ct) -> - line i ppf "Pcl_constraint\n"; - class_expr i ppf ce; - class_type i ppf ct; - | Pcl_extension (s, arg) -> - line i ppf "Pcl_extension \"%s\"\n" s.txt; - payload i ppf arg - | Pcl_open (o, e) -> - line i ppf "Pcl_open %a %a\n" fmt_override_flag o.popen_override - fmt_longident_loc o.popen_expr; - class_expr i ppf e - -and class_structure i ppf { pcstr_self = p; pcstr_fields = l } = - line i ppf "class_structure\n"; - pattern (i+1) ppf p; - list (i+1) class_field ppf l; - -and class_field i ppf x = - line i ppf "class_field %a\n" fmt_location x.pcf_loc; - let i = i + 1 in - attributes i ppf x.pcf_attributes; - match x.pcf_desc with - | Pcf_inherit (ovf, ce, so) -> - line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf; - class_expr (i+1) ppf ce; - option (i+1) string_loc ppf so; - | Pcf_val (s, mf, k) -> - line i ppf "Pcf_val %a\n" fmt_mutable_flag mf; - line (i+1) ppf "%a\n" fmt_string_loc s; - class_field_kind (i+1) ppf k - | Pcf_method (s, pf, k) -> - line i ppf "Pcf_method %a\n" fmt_private_flag pf; - line (i+1) ppf "%a\n" fmt_string_loc s; - class_field_kind (i+1) ppf k - | Pcf_constraint (ct1, ct2) -> - line i ppf "Pcf_constraint\n"; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; - | Pcf_initializer (e) -> - line i ppf "Pcf_initializer\n"; - expression (i+1) ppf e; - | Pcf_attribute a -> - attribute i ppf "Pcf_attribute" a - | Pcf_extension (s, arg) -> - line i ppf "Pcf_extension \"%s\"\n" s.txt; - payload i ppf arg - -and class_field_kind i ppf = function - | Cfk_concrete (o, e) -> - line i ppf "Concrete %a\n" fmt_override_flag o; - expression i ppf e - | Cfk_virtual t -> - line i ppf "Virtual\n"; - core_type i ppf t - -and class_declaration i ppf x = - line i ppf "class_declaration %a\n" fmt_location x.pci_loc; - attributes i ppf x.pci_attributes; - let i = i+1 in - line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; - line i ppf "pci_params =\n"; - list (i+1) type_parameter ppf x.pci_params; - line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; - line i ppf "pci_expr =\n"; - class_expr (i+1) ppf x.pci_expr; - -and module_type i ppf x = - line i ppf "module_type %a\n" fmt_location x.pmty_loc; - attributes i ppf x.pmty_attributes; - let i = i+1 in - match x.pmty_desc with - | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li; - | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li; - | Pmty_signature (s) -> - line i ppf "Pmty_signature\n"; - signature i ppf s; - | Pmty_functor (Unit, mt2) -> - line i ppf "Pmty_functor ()\n"; - module_type i ppf mt2; - | Pmty_functor (Named (s, mt1), mt2) -> - line i ppf "Pmty_functor %a\n" fmt_str_opt_loc s; - module_type i ppf mt1; - module_type i ppf mt2; - | Pmty_with (mt, l) -> - line i ppf "Pmty_with\n"; - module_type i ppf mt; - list i with_constraint ppf l; - | Pmty_typeof m -> - line i ppf "Pmty_typeof\n"; - module_expr i ppf m; - | Pmty_extension (s, arg) -> - line i ppf "Pmod_extension \"%s\"\n" s.txt; - payload i ppf arg - -and signature i ppf x = list i signature_item ppf x - -and signature_item i ppf x = - line i ppf "signature_item %a\n" fmt_location x.psig_loc; - let i = i+1 in - match x.psig_desc with - | Psig_value vd -> - line i ppf "Psig_value\n"; - value_description i ppf vd; - | Psig_type (rf, l) -> - line i ppf "Psig_type %a\n" fmt_rec_flag rf; - list i type_declaration ppf l; - | Psig_typesubst l -> - line i ppf "Psig_typesubst\n"; - list i type_declaration ppf l; - | Psig_typext te -> - line i ppf "Psig_typext\n"; - type_extension i ppf te - | Psig_exception te -> - line i ppf "Psig_exception\n"; - type_exception i ppf te - | Psig_module pmd -> - line i ppf "Psig_module %a\n" fmt_str_opt_loc pmd.pmd_name; - attributes i ppf pmd.pmd_attributes; - module_type i ppf pmd.pmd_type - | Psig_modsubst pms -> - line i ppf "Psig_modsubst %a = %a\n" - fmt_string_loc pms.pms_name - fmt_longident_loc pms.pms_manifest; - attributes i ppf pms.pms_attributes; - | Psig_recmodule decls -> - line i ppf "Psig_recmodule\n"; - list i module_declaration ppf decls; - | Psig_modtype x -> - line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name; - attributes i ppf x.pmtd_attributes; - modtype_declaration i ppf x.pmtd_type - | Psig_modtypesubst x -> - line i ppf "Psig_modtypesubst %a\n" fmt_string_loc x.pmtd_name; - attributes i ppf x.pmtd_attributes; - modtype_declaration i ppf x.pmtd_type - | Psig_open od -> - line i ppf "Psig_open %a %a\n" fmt_override_flag od.popen_override - fmt_longident_loc od.popen_expr; - attributes i ppf od.popen_attributes - | Psig_include incl -> - line i ppf "Psig_include\n"; - module_type i ppf incl.pincl_mod; - attributes i ppf incl.pincl_attributes - | Psig_class (l) -> - line i ppf "Psig_class\n"; - list i class_description ppf l; - | Psig_class_type (l) -> - line i ppf "Psig_class_type\n"; - list i class_type_declaration ppf l; - | Psig_extension ((s, arg), attrs) -> - line i ppf "Psig_extension \"%s\"\n" s.txt; - attributes i ppf attrs; - payload i ppf arg - | Psig_attribute a -> - attribute i ppf "Psig_attribute" a - -and modtype_declaration i ppf = function - | None -> line i ppf "#abstract" - | Some mt -> module_type (i+1) ppf mt - -and with_constraint i ppf x = - match x with - | Pwith_type (lid, td) -> - line i ppf "Pwith_type %a\n" fmt_longident_loc lid; - type_declaration (i+1) ppf td; - | Pwith_typesubst (lid, td) -> - line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid; - type_declaration (i+1) ppf td; - | Pwith_module (lid1, lid2) -> - line i ppf "Pwith_module %a = %a\n" - fmt_longident_loc lid1 - fmt_longident_loc lid2; - | Pwith_modsubst (lid1, lid2) -> - line i ppf "Pwith_modsubst %a = %a\n" - fmt_longident_loc lid1 - fmt_longident_loc lid2; - | Pwith_modtype (lid1, mty) -> - line i ppf "Pwith_modtype %a\n" - fmt_longident_loc lid1; - module_type (i+1) ppf mty - | Pwith_modtypesubst (lid1, mty) -> - line i ppf "Pwith_modtypesubst %a\n" - fmt_longident_loc lid1; - module_type (i+1) ppf mty - -and module_expr i ppf x = - line i ppf "module_expr %a\n" fmt_location x.pmod_loc; - attributes i ppf x.pmod_attributes; - let i = i+1 in - match x.pmod_desc with - | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li; - | Pmod_structure (s) -> - line i ppf "Pmod_structure\n"; - structure i ppf s; - | Pmod_functor (Unit, me) -> - line i ppf "Pmod_functor ()\n"; - module_expr i ppf me; - | Pmod_functor (Named (s, mt), me) -> - line i ppf "Pmod_functor %a\n" fmt_str_opt_loc s; - module_type i ppf mt; - module_expr i ppf me; - | Pmod_apply (me1, me2) -> - line i ppf "Pmod_apply\n"; - module_expr i ppf me1; - module_expr i ppf me2; - | Pmod_apply_unit me1 -> - line i ppf "Pmod_apply_unit\n"; - module_expr i ppf me1 - | Pmod_constraint (me, mt) -> - line i ppf "Pmod_constraint\n"; - module_expr i ppf me; - module_type i ppf mt; - | Pmod_unpack (e) -> - line i ppf "Pmod_unpack\n"; - expression i ppf e; - | Pmod_extension (s, arg) -> - line i ppf "Pmod_extension \"%s\"\n" s.txt; - payload i ppf arg - -and structure i ppf x = list i structure_item ppf x - -and structure_item i ppf x = - line i ppf "structure_item %a\n" fmt_location x.pstr_loc; - let i = i+1 in - match x.pstr_desc with - | Pstr_eval (e, attrs) -> - line i ppf "Pstr_eval\n"; - attributes i ppf attrs; - expression i ppf e; - | Pstr_value (rf, l) -> - line i ppf "Pstr_value %a\n" fmt_rec_flag rf; - list i value_binding ppf l; - | Pstr_primitive vd -> - line i ppf "Pstr_primitive\n"; - value_description i ppf vd; - | Pstr_type (rf, l) -> - line i ppf "Pstr_type %a\n" fmt_rec_flag rf; - list i type_declaration ppf l; - | Pstr_typext te -> - line i ppf "Pstr_typext\n"; - type_extension i ppf te - | Pstr_exception te -> - line i ppf "Pstr_exception\n"; - type_exception i ppf te - | Pstr_module x -> - line i ppf "Pstr_module\n"; - module_binding i ppf x - | Pstr_recmodule bindings -> - line i ppf "Pstr_recmodule\n"; - list i module_binding ppf bindings; - | Pstr_modtype x -> - line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name; - attributes i ppf x.pmtd_attributes; - modtype_declaration i ppf x.pmtd_type - | Pstr_open od -> - line i ppf "Pstr_open %a\n" fmt_override_flag od.popen_override; - module_expr i ppf od.popen_expr; - attributes i ppf od.popen_attributes - | Pstr_class (l) -> - line i ppf "Pstr_class\n"; - list i class_declaration ppf l; - | Pstr_class_type (l) -> - line i ppf "Pstr_class_type\n"; - list i class_type_declaration ppf l; - | Pstr_include incl -> - line i ppf "Pstr_include"; - attributes i ppf incl.pincl_attributes; - module_expr i ppf incl.pincl_mod - | Pstr_extension ((s, arg), attrs) -> - line i ppf "Pstr_extension \"%s\"\n" s.txt; - attributes i ppf attrs; - payload i ppf arg - | Pstr_attribute a -> - attribute i ppf "Pstr_attribute" a - -and module_declaration i ppf pmd = - str_opt_loc i ppf pmd.pmd_name; - attributes i ppf pmd.pmd_attributes; - module_type (i+1) ppf pmd.pmd_type; - -and module_binding i ppf x = - str_opt_loc i ppf x.pmb_name; - attributes i ppf x.pmb_attributes; - module_expr (i+1) ppf x.pmb_expr - -and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = - line i ppf " %a\n" fmt_location l; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; - -and constructor_decl i ppf - {pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes} = - line i ppf "%a\n" fmt_location pcd_loc; - line (i+1) ppf "%a\n" fmt_string_loc pcd_name; - if pcd_vars <> [] then line (i+1) ppf "pcd_vars =%a\n" typevars pcd_vars; - attributes i ppf pcd_attributes; - constructor_arguments (i+1) ppf pcd_args; - option (i+1) core_type ppf pcd_res - -and constructor_arguments i ppf = function - | Pcstr_tuple l -> list i core_type ppf l - | Pcstr_record l -> list i label_decl ppf l - -and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}= - line i ppf "%a\n" fmt_location pld_loc; - attributes i ppf pld_attributes; - line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable; - line (i+1) ppf "%a" fmt_string_loc pld_name; - core_type (i+1) ppf pld_type - -and longident_x_pattern i ppf (li, p) = - line i ppf "%a\n" fmt_longident_loc li; - pattern (i+1) ppf p; - -and case i ppf {pc_lhs; pc_guard; pc_rhs} = - line i ppf "\n"; - pattern (i+1) ppf pc_lhs; - begin match pc_guard with - | None -> () - | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g - end; - expression (i+1) ppf pc_rhs; - -and value_binding i ppf x = - line i ppf "\n"; - attributes (i+1) ppf x.pvb_attributes; - pattern (i+1) ppf x.pvb_pat; - Option.iter (value_constraint (i+1) ppf) x.pvb_constraint; - expression (i+1) ppf x.pvb_expr - -and value_constraint i ppf x = - let pp_sep ppf () = Format.fprintf ppf "@ "; in - let pp_newtypes = Format.pp_print_list fmt_string_loc ~pp_sep in - match x with - | Pvc_constraint { locally_abstract_univars = []; typ } -> - core_type i ppf typ - | Pvc_constraint { locally_abstract_univars=newtypes; typ} -> - line i ppf " %a.\n" pp_newtypes newtypes; - core_type i ppf typ - | Pvc_coercion { ground; coercion} -> - line i ppf "\n"; - option i core_type ppf ground; - core_type i ppf coercion; - - -and binding_op i ppf x = - line i ppf " %a %a" - fmt_string_loc x.pbop_op fmt_location x.pbop_loc; - pattern (i+1) ppf x.pbop_pat; - expression (i+1) ppf x.pbop_exp; - -and string_x_expression i ppf (s, e) = - line i ppf " %a\n" fmt_string_loc s; - expression (i+1) ppf e; - -and longident_x_expression i ppf (li, e) = - line i ppf "%a\n" fmt_longident_loc li; - expression (i+1) ppf e; - -and label_x_expression i ppf (l,e) = - line i ppf "\n"; - arg_label i ppf l; - expression (i+1) ppf e; - -and label_x_bool_x_core_type_list i ppf x = - match x.prf_desc with - Rtag (l, b, ctl) -> - line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b); - attributes (i+1) ppf x.prf_attributes; - list (i+1) core_type ppf ctl - | Rinherit (ct) -> - line i ppf "Rinherit\n"; - core_type (i+1) ppf ct - -let rec toplevel_phrase i ppf x = - match x with - | Ptop_def (s) -> - line i ppf "Ptop_def\n"; - structure (i+1) ppf s; - | Ptop_dir {pdir_name; pdir_arg; _} -> - line i ppf "Ptop_dir \"%s\"\n" pdir_name.txt; - match pdir_arg with - | None -> () - | Some da -> directive_argument i ppf da; - -and directive_argument i ppf x = - match x.pdira_desc with - | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s - | Pdir_int (n, None) -> line i ppf "Pdir_int %s\n" n - | Pdir_int (n, Some m) -> line i ppf "Pdir_int %s%c\n" n m - | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li - | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b) - -let interface ppf x = list 0 signature_item ppf x - -let implementation ppf x = list 0 structure_item ppf x - -let top_phrase ppf x = toplevel_phrase 0 ppf x diff --git a/parsing/printast.mli b/parsing/printast.mli deleted file mode 100644 index 5bc496182f..0000000000 --- a/parsing/printast.mli +++ /dev/null @@ -1,32 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Damien Doligez, projet Para, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Raw printer for {!Parsetree} - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Parsetree -open Format - -val interface : formatter -> signature_item list -> unit -val implementation : formatter -> structure_item list -> unit -val top_phrase : formatter -> toplevel_phrase -> unit - -val expression: int -> formatter -> expression -> unit -val structure: int -> formatter -> structure -> unit -val payload: int -> formatter -> payload -> unit diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml deleted file mode 100644 index df7b8a0548..0000000000 --- a/parsing/syntaxerr.ml +++ /dev/null @@ -1,45 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Auxiliary type for reporting syntax errors *) - -type error = - Unclosed of Location.t * string * Location.t * string - | Expecting of Location.t * string - | Not_expecting of Location.t * string - | Applicative_path of Location.t - | Variable_in_scope of Location.t * string - | Other of Location.t - | Ill_formed_ast of Location.t * string - | Invalid_package_type of Location.t * string - | Removed_string_set of Location.t - -exception Error of error -exception Escape_error - -let location_of_error = function - | Unclosed(l,_,_,_) - | Applicative_path l - | Variable_in_scope(l,_) - | Other l - | Not_expecting (l, _) - | Ill_formed_ast (l, _) - | Invalid_package_type (l, _) - | Expecting (l, _) - | Removed_string_set l -> l - - -let ill_formed_ast loc s = - raise (Error (Ill_formed_ast (loc, s))) diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli deleted file mode 100644 index 577d5360cd..0000000000 --- a/parsing/syntaxerr.mli +++ /dev/null @@ -1,38 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Auxiliary type for reporting syntax errors - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -type error = - Unclosed of Location.t * string * Location.t * string - | Expecting of Location.t * string - | Not_expecting of Location.t * string - | Applicative_path of Location.t - | Variable_in_scope of Location.t * string - | Other of Location.t - | Ill_formed_ast of Location.t * string - | Invalid_package_type of Location.t * string - | Removed_string_set of Location.t - -exception Error of error -exception Escape_error - -val location_of_error: error -> Location.t -val ill_formed_ast: Location.t -> string -> 'a diff --git a/typing/outcometree.mli b/typing/outcometree.mli deleted file mode 100644 index 0fc50b90db..0000000000 --- a/typing/outcometree.mli +++ /dev/null @@ -1,155 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Module [Outcometree]: results displayed by the toplevel *) - -(* These types represent messages that the toplevel displays as normal - results or errors. The real displaying is customisable using the hooks: - [Toploop.print_out_value] - [Toploop.print_out_type] - [Toploop.print_out_sig_item] - [Toploop.print_out_phrase] *) - -(** An [out_name] is a string representation of an identifier which can be - rewritten on the fly to avoid name collisions *) -type out_name = { mutable printed_name: string } - -type out_ident = - | Oide_apply of out_ident * out_ident - | Oide_dot of out_ident * string - | Oide_ident of out_name - -type out_string = - | Ostr_string - | Ostr_bytes - -type out_attribute = - { oattr_name: string } - -type out_value = - | Oval_array of out_value list - | Oval_char of char - | Oval_constr of out_ident * out_value list - | Oval_ellipsis - | Oval_float of float - | Oval_int of int - | Oval_int32 of int32 - | Oval_int64 of int64 - | Oval_nativeint of nativeint - | Oval_list of out_value list - | Oval_printer of (Format.formatter -> unit) - | Oval_record of (out_ident * out_value) list - | Oval_string of string * int * out_string (* string, size-to-print, kind *) - | Oval_stuff of string - | Oval_tuple of out_value list - | Oval_variant of string * out_value option - -type out_type_param = string * (Asttypes.variance * Asttypes.injectivity) - -type out_type = - | Otyp_abstract - | Otyp_open - | Otyp_alias of {non_gen:bool; aliased:out_type; alias:string} - | Otyp_arrow of string * out_type * out_type - | Otyp_class of out_ident * out_type list - | Otyp_constr of out_ident * out_type list - | Otyp_manifest of out_type * out_type - | Otyp_object of { fields: (string * out_type) list; open_row:bool} - | Otyp_record of (string * bool * out_type) list - | Otyp_stuff of string - | Otyp_sum of out_constructor list - | Otyp_tuple of out_type list - | Otyp_var of bool * string - | Otyp_variant of out_variant * bool * (string list) option - | Otyp_poly of string list * out_type - | Otyp_module of out_ident * (string * out_type) list - | Otyp_attribute of out_type * out_attribute - -and out_constructor = { - ocstr_name: string; - ocstr_args: out_type list; - ocstr_return_type: out_type option; -} - -and out_variant = - | Ovar_fields of (string * bool * out_type list) list - | Ovar_typ of out_type - -type out_class_type = - | Octy_constr of out_ident * out_type list - | Octy_arrow of string * out_type * out_class_type - | Octy_signature of out_type option * out_class_sig_item list -and out_class_sig_item = - | Ocsg_constraint of out_type * out_type - | Ocsg_method of string * bool * bool * out_type - | Ocsg_value of string * bool * bool * out_type - -type out_module_type = - | Omty_abstract - | Omty_functor of (string option * out_module_type) option * out_module_type - | Omty_ident of out_ident - | Omty_signature of out_sig_item list - | Omty_alias of out_ident -and out_sig_item = - | Osig_class of - bool * string * out_type_param list * out_class_type * - out_rec_status - | Osig_class_type of - bool * string * out_type_param list * out_class_type * - out_rec_status - | Osig_typext of out_extension_constructor * out_ext_status - | Osig_modtype of string * out_module_type - | Osig_module of string * out_module_type * out_rec_status - | Osig_type of out_type_decl * out_rec_status - | Osig_value of out_val_decl - | Osig_ellipsis -and out_type_decl = - { otype_name: string; - otype_params: out_type_param list; - otype_type: out_type; - otype_private: Asttypes.private_flag; - otype_immediate: Type_immediacy.t; - otype_unboxed: bool; - otype_cstrs: (out_type * out_type) list } -and out_extension_constructor = - { oext_name: string; - oext_type_name: string; - oext_type_params: string list; - oext_args: out_type list; - oext_ret_type: out_type option; - oext_private: Asttypes.private_flag } -and out_type_extension = - { otyext_name: string; - otyext_params: string list; - otyext_constructors: out_constructor list; - otyext_private: Asttypes.private_flag } -and out_val_decl = - { oval_name: string; - oval_type: out_type; - oval_prims: string list; - oval_attributes: out_attribute list } -and out_rec_status = - | Orec_not - | Orec_first - | Orec_next -and out_ext_status = - | Oext_first - | Oext_next - | Oext_exception - -type out_phrase = - | Ophr_eval of out_value * out_type - | Ophr_signature of (out_sig_item * out_value option) list - | Ophr_exception of (exn * out_value) diff --git a/typing/path.ml b/typing/path.ml deleted file mode 100644 index 69b8f34a01..0000000000 --- a/typing/path.ml +++ /dev/null @@ -1,144 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type t = - Pident of Ident.t - | Pdot of t * string - | Papply of t * t - | Pextra_ty of t * extra_ty -and extra_ty = - | Pcstr_ty of string - | Pext_ty - -let rec same p1 p2 = - p1 == p2 - || match (p1, p2) with - (Pident id1, Pident id2) -> Ident.same id1 id2 - | (Pdot(p1, s1), Pdot(p2, s2)) -> - s1 = s2 && same p1 p2 - | (Papply(fun1, arg1), Papply(fun2, arg2)) -> - same fun1 fun2 && same arg1 arg2 - | (Pextra_ty (p1, t1), Pextra_ty (p2, t2)) -> - let same_extra = match t1, t2 with - | (Pcstr_ty s1, Pcstr_ty s2) -> s1 = s2 - | (Pext_ty, Pext_ty) -> true - | ((Pcstr_ty _ | Pext_ty), _) -> false - in same_extra && same p1 p2 - | (_, _) -> false - -let rec compare p1 p2 = - if p1 == p2 then 0 - else match (p1, p2) with - (Pident id1, Pident id2) -> Ident.compare id1 id2 - | (Pdot(p1, s1), Pdot(p2, s2)) -> - let h = compare p1 p2 in - if h <> 0 then h else String.compare s1 s2 - | (Papply(fun1, arg1), Papply(fun2, arg2)) -> - let h = compare fun1 fun2 in - if h <> 0 then h else compare arg1 arg2 - | (Pextra_ty (p1, t1), Pextra_ty (p2, t2)) -> - let h = compare_extra t1 t2 in - if h <> 0 then h else compare p1 p2 - | (Pident _, (Pdot _ | Papply _ | Pextra_ty _)) - | (Pdot _, (Papply _ | Pextra_ty _)) - | (Papply _, Pextra_ty _) - -> -1 - | ((Pextra_ty _ | Papply _ | Pdot _), Pident _) - | ((Pextra_ty _ | Papply _) , Pdot _) - | (Pextra_ty _, Papply _) - -> 1 -and compare_extra t1 t2 = - match (t1, t2) with - Pcstr_ty s1, Pcstr_ty s2 -> String.compare s1 s2 - | (Pext_ty, Pext_ty) - -> 0 - | (Pcstr_ty _, Pext_ty) - -> -1 - | (Pext_ty, Pcstr_ty _) - -> 1 - -let rec find_free_opt ids = function - Pident id -> List.find_opt (Ident.same id) ids - | Pdot(p, _) | Pextra_ty (p, _) -> find_free_opt ids p - | Papply(p1, p2) -> begin - match find_free_opt ids p1 with - | None -> find_free_opt ids p2 - | Some _ as res -> res - end - -let exists_free ids p = - match find_free_opt ids p with - | None -> false - | _ -> true - -let rec scope = function - Pident id -> Ident.scope id - | Pdot(p, _) | Pextra_ty (p, _) -> scope p - | Papply(p1, p2) -> Int.max (scope p1) (scope p2) - -let kfalse _ = false - -let rec name ?(paren=kfalse) = function - Pident id -> Ident.name id - | Pdot(p, s) | Pextra_ty (p, Pcstr_ty s) -> - name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s - | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")" - | Pextra_ty (p, Pext_ty) -> name ~paren p - -let rec print ppf = function - | Pident id -> Ident.print_with_scope ppf id - | Pdot(p, s) | Pextra_ty (p, Pcstr_ty s) -> - Format.fprintf ppf "%a.%s" print p s - | Papply(p1, p2) -> Format.fprintf ppf "%a(%a)" print p1 print p2 - | Pextra_ty (p, Pext_ty) -> print ppf p - -let rec head = function - Pident id -> id - | Pdot(p, _) | Pextra_ty (p, _) -> head p - | Papply _ -> assert false - -let flatten = - let rec flatten acc = function - | Pident id -> `Ok (id, acc) - | Pdot (p, s) | Pextra_ty (p, Pcstr_ty s) -> flatten (s :: acc) p - | Papply _ -> `Contains_apply - | Pextra_ty (p, Pext_ty) -> flatten acc p - in - fun t -> flatten [] t - -let heads p = - let rec heads p acc = match p with - | Pident id -> id :: acc - | Pdot (p, _) | Pextra_ty (p, _) -> heads p acc - | Papply(p1, p2) -> - heads p1 (heads p2 acc) - in heads p [] - -let rec last = function - | Pident id -> Ident.name id - | Pdot(_, s) | Pextra_ty (_, Pcstr_ty s) -> s - | Papply(_, p) | Pextra_ty (p, Pext_ty) -> last p - -let is_constructor_typath p = - match p with - | Pident _ | Pdot _ | Papply _ -> false - | Pextra_ty _ -> true - -module T = struct - type nonrec t = t - let compare = compare -end -module Set = Set.Make(T) -module Map = Map.Make(T) diff --git a/typing/path.mli b/typing/path.mli deleted file mode 100644 index 39e76a3727..0000000000 --- a/typing/path.mli +++ /dev/null @@ -1,80 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Access paths *) - -type t = - | Pident of Ident.t - (** Examples: x, List, int *) - | Pdot of t * string - (** Examples: List.map, Float.Array *) - | Papply of t * t - (** Examples: Set.Make(Int), Map.Make(Set.Make(Int)) *) - | Pextra_ty of t * extra_ty - (** [Pextra_ty (p, extra)] are additional paths of types - introduced by specific OCaml constructs. See below. - *) -and extra_ty = - | Pcstr_ty of string - (** [Pextra_ty (p, Pcstr_ty c)] is the type of the inline record for - constructor [c] inside type [p]. - - For example, in - {[ - type 'a t = Nil | Cons of {hd : 'a; tl : 'a t} - ]} - - The inline record type [{hd : 'a; tl : 'a t}] cannot - be named by the user in the surface syntax, but internally - it has the path - [Pextra_ty (Pident `t`, Pcstr_ty "Cons")]. - *) - | Pext_ty - (** [Pextra_ty (p, Pext_ty)] is the type of the inline record for - the extension constructor [p]. - - For example, in - {[ - type exn += Error of {loc : loc; msg : string} - ]} - - The inline record type [{loc : loc; msg : string}] cannot - be named by the user in the surface syntax, but internally - it has the path - [Pextra_ty (Pident `Error`, Pext_ty)]. - *) - -val same: t -> t -> bool -val compare: t -> t -> int -val compare_extra: extra_ty -> extra_ty -> int -val find_free_opt: Ident.t list -> t -> Ident.t option -val exists_free: Ident.t list -> t -> bool -val scope: t -> int -val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ] - -val name: ?paren:(string -> bool) -> t -> string - (* [paren] tells whether a path suffix needs parentheses *) -val head: t -> Ident.t - -val print: Format.formatter -> t -> unit - -val heads: t -> Ident.t list - -val last: t -> string - -val is_constructor_typath: t -> bool - -module Map : Map.S with type key = t -module Set : Set.S with type elt = t diff --git a/typing/type_immediacy.ml b/typing/type_immediacy.ml deleted file mode 100644 index 557ed4271a..0000000000 --- a/typing/type_immediacy.ml +++ /dev/null @@ -1,43 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jeremie Dimino, Jane Street Europe *) -(* *) -(* Copyright 2019 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type t = - | Unknown - | Always - | Always_on_64bits - -module Violation = struct - type t = - | Not_always_immediate - | Not_always_immediate_on_64bits -end - -let coerce t ~as_ = - match t, as_ with - | _, Unknown - | Always, Always - | (Always | Always_on_64bits), Always_on_64bits -> Ok () - | (Unknown | Always_on_64bits), Always -> - Error Violation.Not_always_immediate - | Unknown, Always_on_64bits -> - Error Violation.Not_always_immediate_on_64bits - -let of_attributes attrs = - match - Builtin_attributes.immediate attrs, - Builtin_attributes.immediate64 attrs - with - | true, _ -> Always - | false, true -> Always_on_64bits - | false, false -> Unknown diff --git a/typing/type_immediacy.mli b/typing/type_immediacy.mli deleted file mode 100644 index 3fc2e3b4f9..0000000000 --- a/typing/type_immediacy.mli +++ /dev/null @@ -1,40 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jeremie Dimino, Jane Street Europe *) -(* *) -(* Copyright 2019 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Immediacy status of a type *) - -type t = - | Unknown - (** We don't know anything *) - | Always - (** We know for sure that values of this type are always immediate *) - | Always_on_64bits - (** We know for sure that values of this type are always immediate - on 64 bit platforms. For other platforms, we know nothing. *) - -module Violation : sig - type t = - | Not_always_immediate - | Not_always_immediate_on_64bits -end - -(** [coerce t ~as_] returns [Ok ()] iff [t] can be seen as type - immediacy [as_]. For instance, [Always] can be seen as - [Always_on_64bits] but the opposite is not true. Return [Error _] - if the coercion is not possible. *) -val coerce : t -> as_:t -> (unit, Violation.t) result - -(** Return the immediateness of a type as indicated by the user via - attributes *) -val of_attributes : Parsetree.attributes -> t diff --git a/utils/consistbl.ml b/utils/consistbl.ml deleted file mode 100644 index 29289201f6..0000000000 --- a/utils/consistbl.ml +++ /dev/null @@ -1,95 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Consistency tables: for checking consistency of module CRCs *) - -open Misc - -module Make (Module_name : sig - type t - module Set : Set.S with type elt = t - module Map : Map.S with type key = t - module Tbl : Hashtbl.S with type key = t - val compare : t -> t -> int -end) = struct - type t = (Digest.t * filepath) Module_name.Tbl.t - - let create () = Module_name.Tbl.create 13 - - let clear = Module_name.Tbl.clear - - exception Inconsistency of { - unit_name : Module_name.t; - inconsistent_source : string; - original_source : string; - } - - exception Not_available of Module_name.t - - let check_ tbl name crc source = - let (old_crc, old_source) = Module_name.Tbl.find tbl name in - if crc <> old_crc then raise(Inconsistency { - unit_name = name; - inconsistent_source = source; - original_source = old_source; - }) - - let check tbl name crc source = - try check_ tbl name crc source - with Not_found -> - Module_name.Tbl.add tbl name (crc, source) - - let check_noadd tbl name crc source = - try check_ tbl name crc source - with Not_found -> - raise (Not_available name) - - let source tbl name = snd (Module_name.Tbl.find tbl name) - - let extract l tbl = - let l = List.sort_uniq Module_name.compare l in - List.fold_left - (fun assc name -> - try - let (crc, _) = Module_name.Tbl.find tbl name in - (name, Some crc) :: assc - with Not_found -> - (name, None) :: assc) - [] l - - let extract_map mod_names tbl = - Module_name.Set.fold - (fun name result -> - try - let (crc, _) = Module_name.Tbl.find tbl name in - Module_name.Map.add name (Some crc) result - with Not_found -> - Module_name.Map.add name None result) - mod_names - Module_name.Map.empty - - let filter p tbl = - let to_remove = ref [] in - Module_name.Tbl.iter - (fun name _ -> - if not (p name) then to_remove := name :: !to_remove) - tbl; - List.iter - (fun name -> - while Module_name.Tbl.mem tbl name do - Module_name.Tbl.remove tbl name - done) - !to_remove -end diff --git a/utils/consistbl.mli b/utils/consistbl.mli deleted file mode 100644 index acc89eb31d..0000000000 --- a/utils/consistbl.mli +++ /dev/null @@ -1,77 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Consistency tables: for checking consistency of module CRCs - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Misc - -module Make (Module_name : sig - type t - module Set : Set.S with type elt = t - module Map : Map.S with type key = t - module Tbl : Hashtbl.S with type key = t - val compare : t -> t -> int -end) : sig - type t - - val create: unit -> t - - val clear: t -> unit - - val check: t -> Module_name.t -> Digest.t -> filepath -> unit - (* [check tbl name crc source] - checks consistency of ([name], [crc]) with infos previously - stored in [tbl]. If no CRC was previously associated with - [name], record ([name], [crc]) in [tbl]. - [source] is the name of the file from which the information - comes from. This is used for error reporting. *) - - val check_noadd: t -> Module_name.t -> Digest.t -> filepath -> unit - (* Same as [check], but raise [Not_available] if no CRC was previously - associated with [name]. *) - - val source: t -> Module_name.t -> filepath - (* [source tbl name] returns the file name associated with [name] - if the latter has an associated CRC in [tbl]. - Raise [Not_found] otherwise. *) - - val extract: Module_name.t list -> t -> (Module_name.t * Digest.t option) list - (* [extract tbl names] returns an associative list mapping each string - in [names] to the CRC associated with it in [tbl]. If no CRC is - associated with a name then it is mapped to [None]. *) - - val extract_map : Module_name.Set.t -> t -> Digest.t option Module_name.Map.t - (* Like [extract] but with a more sophisticated type. *) - - val filter: (Module_name.t -> bool) -> t -> unit - (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs - such that [pred name] is [false]. *) - - exception Inconsistency of { - unit_name : Module_name.t; - inconsistent_source : string; - original_source : string; - } - (* Raised by [check] when a CRC mismatch is detected. *) - - exception Not_available of Module_name.t - (* Raised by [check_noadd] when a name doesn't have an associated - CRC. *) -end diff --git a/utils/diffing_with_keys.ml b/utils/diffing_with_keys.ml deleted file mode 100644 index 3e1ea13680..0000000000 --- a/utils/diffing_with_keys.ml +++ /dev/null @@ -1,208 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Florian Angeletti, projet Cambium, Inria Paris *) -(* *) -(* Copyright 2021 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - - -type 'a with_pos = {pos:int; data:'a} -let with_pos l = List.mapi (fun n data -> {pos=n+1; data}) l - -(** Composite change and mismatches *) -type ('l,'r,'diff) mismatch = - | Name of {pos:int; got:string; expected:string; types_match:bool} - | Type of {pos:int; got:'l; expected:'r; reason:'diff} - -type ('l,'r,'diff) change = - | Change of ('l,'r,'diff) mismatch - | Swap of { pos: int * int; first: string; last: string } - | Move of {name:string; got:int; expected:int} - | Insert of {pos:int; insert:'r} - | Delete of {pos:int; delete:'l} - -let prefix ppf x = - let kind = match x with - | Change _ | Swap _ | Move _ -> Diffing.Modification - | Insert _ -> Diffing.Insertion - | Delete _ -> Diffing.Deletion - in - let style k ppf inner = - let sty = Diffing.style k in - Format.pp_open_stag ppf (Misc.Color.Style sty); - Format.kfprintf (fun ppf -> Format.pp_close_stag ppf () ) ppf inner - in - match x with - | Change (Name {pos; _ } | Type {pos; _}) - | Insert { pos; _ } | Delete { pos; _ } -> - style kind ppf "%i. " pos - | Swap { pos = left, right; _ } -> - style kind ppf "%i<->%i. " left right - | Move { got; expected; _ } -> - style kind ppf "%i->%i. " expected got - - - -(** To detect [move] and [swaps], we are using the fact that - there are 2-cycles in the graph of name renaming. - - [Change (x,y,_) is then an edge from - [key_left x] to [key_right y]. - - [Insert x] is an edge between the special node epsilon and - [key_left x] - - [Delete x] is an edge between [key_right] and the epsilon node - Since for 2-cycle, knowing one edge is enough to identify the cycle - it might belong to, we are using maps of partial 2-cycles. -*) -module Two_cycle: sig - type t = private (string * string) - val create: string -> string -> t -end = struct - type t = string * string - let create kx ky = - if kx <= ky then kx, ky else ky, kx -end -module Swap = Map.Make(struct - type t = Two_cycle.t - let compare: t -> t -> int = Stdlib.compare - end) -module Move = Misc.Stdlib.String.Map - - -module Define(D:Diffing.Defs with type eq := unit) = struct - - module Internal_defs = struct - type left = D.left with_pos - type right = D.right with_pos - type diff = (D.left, D.right, D.diff) mismatch - type eq = unit - type state = D.state - end - module Diff = Diffing.Define(Internal_defs) - - type left = Internal_defs.left - type right = Internal_defs.right - type diff = (D.left, D.right, D.diff) mismatch - type composite_change = (D.left,D.right,D.diff) change - type nonrec change = (left, right, unit, diff) Diffing.change - type patch = composite_change list - - module type Parameters = sig - include Diff.Parameters with type update_result := D.state - val key_left: D.left -> string - val key_right: D.right -> string - end - - module Simple(Impl:Parameters) = struct - open Impl - - (** Partial 2-cycles *) - type ('l,'r) partial_cycle = - | Left of int * D.state * 'l - | Right of int * D.state * 'r - | Both of D.state * 'l * 'r - - (** Compute the partial cycle and edge associated to an edge *) - let edge state (x:left) (y:right) = - let kx, ky = key_left x.data, key_right y.data in - let edge = - if kx <= ky then - Left (x.pos, state, (x,y)) - else - Right (x.pos,state, (x,y)) - in - Two_cycle.create kx ky, edge - - let merge_edge ex ey = match ex, ey with - | ex, None -> Some ex - | Left (lpos, lstate, l), Some Right (rpos, rstate,r) - | Right (rpos, rstate,r), Some Left (lpos, lstate, l) -> - let state = if lpos < rpos then rstate else lstate in - Some (Both (state,l,r)) - | Both _ as b, _ | _, Some (Both _ as b) -> Some b - | l, _ -> Some l - - let two_cycles state changes = - let add (state,(swaps,moves)) (d:change) = - update d state, - match d with - | Change (x,y,_) -> - let k, edge = edge state x y in - Swap.update k (merge_edge edge) swaps, moves - | Insert nx -> - let k = key_right nx.data in - let edge = Right (nx.pos, state,nx) in - swaps, Move.update k (merge_edge edge) moves - | Delete nx -> - let k, edge = key_left nx.data, Left (nx.pos, state, nx) in - swaps, Move.update k (merge_edge edge) moves - | _ -> swaps, moves - in - List.fold_left add (state,(Swap.empty,Move.empty)) changes - - (** Check if an edge belongs to a known 2-cycle *) - let swap swaps x y = - let kx, ky = key_left x.data, key_right y.data in - let key = Two_cycle.create kx ky in - match Swap.find_opt key swaps with - | None | Some (Left _ | Right _)-> None - | Some Both (state, (ll,lr),(rl,rr)) -> - match test state ll rr, test state rl lr with - | Ok _, Ok _ -> - Some ({pos=ll.pos; data=kx}, {pos=rl.pos; data=ky}) - | Error _, _ | _, Error _ -> None - - let move moves x = - let name = - match x with - | Either.Left x -> key_left x.data - | Either.Right x -> key_right x.data - in - match Move.find_opt name moves with - | None | Some (Left _ | Right _)-> None - | Some Both (state,got,expected) -> - match test state got expected with - | Ok _ -> - Some (Move {name; got=got.pos; expected=expected.pos}) - | Error _ -> None - - let refine state patch = - let _, (swaps, moves) = two_cycles state patch in - let filter: change -> composite_change option = function - | Keep _ -> None - | Insert x -> - begin match move moves (Either.Right x) with - | Some _ as move -> move - | None -> Some (Insert {pos=x.pos;insert=x.data}) - end - | Delete x -> - begin match move moves (Either.Left x) with - | Some _ -> None - | None -> Some (Delete {pos=x.pos; delete=x.data}) - end - | Change(x,y, reason) -> - match swap swaps x y with - | Some ({pos=pos1; data=first}, {pos=pos2; data=last}) -> - if x.pos = pos1 then - Some (Swap { pos = pos1, pos2; first; last}) - else None - | None -> Some (Change reason) - in - List.filter_map filter patch - - let diff state left right = - let left = with_pos left in - let right = with_pos right in - let module Raw = Diff.Simple(Impl) in - let raw = Raw.diff state (Array.of_list left) (Array.of_list right) in - refine state raw - - end -end diff --git a/utils/diffing_with_keys.mli b/utils/diffing_with_keys.mli deleted file mode 100644 index 2da8268767..0000000000 --- a/utils/diffing_with_keys.mli +++ /dev/null @@ -1,77 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Florian Angeletti, projet Cambium, Inria Paris *) -(* *) -(* Copyright 2021 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** - - When diffing lists where each element has a distinct key, we can refine - the diffing patch by introducing two composite edit moves: swaps and moves. - - [Swap]s exchange the position of two elements. [Swap] cost is set to - [2 * change - epsilon]. - [Move]s change the position of one element. [Move] cost is set to - [delete + addition - epsilon]. - - When the cost [delete + addition] is greater than [change] and with those - specific weights, the optimal patch with [Swap]s and [Move]s can be computed - directly and cheaply from the original optimal patch. - -*) - -type 'a with_pos = {pos: int; data:'a} -val with_pos: 'a list -> 'a with_pos list - -type ('l,'r,'diff) mismatch = - | Name of {pos:int; got:string; expected:string; types_match:bool} - | Type of {pos:int; got:'l; expected:'r; reason:'diff} - -(** This specialized version of changes introduces two composite - changes: [Move] and [Swap] -*) -type ('l,'r,'diff) change = - | Change of ('l,'r,'diff) mismatch - | Swap of { pos: int * int; first: string; last: string } - | Move of {name:string; got:int; expected:int} - | Insert of {pos:int; insert:'r} - | Delete of {pos:int; delete:'l} - -val prefix: Format.formatter -> ('l,'r,'diff) change -> unit - -module Define(D:Diffing.Defs with type eq := unit): sig - - type diff = (D.left, D.right, D.diff) mismatch - type left = D.left with_pos - type right = D.right with_pos - - (** Composite changes and patches *) - type composite_change = (D.left,D.right,D.diff) change - type patch = composite_change list - - (** Atomic changes *) - type change = (left,right,unit,diff) Diffing.change - - module type Parameters = sig - val weight: change -> int - val test: D.state -> left -> right -> (unit, diff) result - val update: change -> D.state -> D.state - - val key_left: D.left -> string - val key_right: D.right -> string - end - - module Simple: Parameters -> sig - val diff: D.state -> D.left list -> D.right list -> patch - end - -end diff --git a/utils/lazy_backtrack.ml b/utils/lazy_backtrack.ml deleted file mode 100644 index 13e4eb4400..0000000000 --- a/utils/lazy_backtrack.ml +++ /dev/null @@ -1,87 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type ('a,'b) t = ('a,'b) eval ref - -and ('a,'b) eval = - | Done of 'b - | Raise of exn - | Thunk of 'a - -type undo = - | Nil - | Cons : ('a, 'b) t * 'a * undo -> undo - -type log = undo ref - -let force f x = - match !x with - | Done x -> x - | Raise e -> raise e - | Thunk e -> - match f e with - | y -> - x := Done y; - y - | exception e -> - x := Raise e; - raise e - -let get_arg x = - match !x with Thunk a -> Some a | _ -> None - -let get_contents x = - match !x with - | Thunk a -> Either.Left a - | Done b -> Either.Right b - | Raise e -> raise e - -let create x = - ref (Thunk x) - -let create_forced y = - ref (Done y) - -let create_failed e = - ref (Raise e) - -let log () = - ref Nil - -let force_logged log f x = - match !x with - | Done x -> x - | Raise e -> raise e - | Thunk e -> - match f e with - | (Error _ as err : _ result) -> - x := Done err; - log := Cons(x, e, !log); - err - | Ok _ as res -> - x := Done res; - res - | exception e -> - x := Raise e; - raise e - -let backtrack log = - let rec loop = function - | Nil -> () - | Cons(x, e, rest) -> - x := Thunk e; - loop rest - in - loop !log diff --git a/utils/lazy_backtrack.mli b/utils/lazy_backtrack.mli deleted file mode 100644 index 4e2fbd3808..0000000000 --- a/utils/lazy_backtrack.mli +++ /dev/null @@ -1,34 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type ('a,'b) t - -type log - -val force : ('a -> 'b) -> ('a,'b) t -> 'b -val create : 'a -> ('a,'b) t -val get_arg : ('a,'b) t -> 'a option -val get_contents : ('a,'b) t -> ('a,'b) Either.t -val create_forced : 'b -> ('a, 'b) t -val create_failed : exn -> ('a, 'b) t - -(* [force_logged log f t] is equivalent to [force f t] but if [f] - returns [Error _] then [t] is recorded in [log]. [backtrack log] - will then reset all the recorded [t]s back to their original - state. *) -val log : unit -> log -val force_logged : - log -> ('a -> ('b, 'c) result) -> ('a,('b, 'c) result) t -> ('b, 'c) result -val backtrack : log -> unit diff --git a/utils/load_path.ml b/utils/load_path.ml deleted file mode 100644 index 42330d5623..0000000000 --- a/utils/load_path.ml +++ /dev/null @@ -1,176 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jeremie Dimino, Jane Street Europe *) -(* *) -(* Copyright 2018 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Local_store - -module STbl = Misc.Stdlib.String.Tbl - -(* Mapping from basenames to full filenames *) -type registry = string STbl.t - -let files : registry ref = s_table STbl.create 42 -let files_uncap : registry ref = s_table STbl.create 42 - -module Dir = struct - type t = { - path : string; - files : string list; - } - - let path t = t.path - let files t = t.files - - let find t fn = - if List.mem fn t.files then - Some (Filename.concat t.path fn) - else - None - - let find_uncap t fn = - let fn = String.uncapitalize_ascii fn in - let search base = - if String.uncapitalize_ascii base = fn then - Some (Filename.concat t.path base) - else - None - in - List.find_map search t.files - - (* For backward compatibility reason, simulate the behavior of - [Misc.find_in_path]: silently ignore directories that don't exist - + treat [""] as the current directory. *) - let readdir_compat dir = - try - Sys.readdir (if dir = "" then Filename.current_dir_name else dir) - with Sys_error _ -> - [||] - - let create path = - { path; files = Array.to_list (readdir_compat path) } -end - -type auto_include_callback = - (Dir.t -> string -> string option) -> string -> string - -let dirs = s_ref [] -let no_auto_include _ _ = raise Not_found -let auto_include_callback = ref no_auto_include - -let reset () = - assert (not Config.merlin || Local_store.is_bound ()); - STbl.clear !files; - STbl.clear !files_uncap; - dirs := []; - auto_include_callback := no_auto_include - -let get () = List.rev !dirs -let get_paths () = List.rev_map Dir.path !dirs - -(* Optimized version of [add] below, for use in [init] and [remove_dir]: since - we are starting from an empty cache, we can avoid checking whether a unit - name already exists in the cache simply by adding entries in reverse - order. *) -let prepend_add dir = - List.iter (fun base -> - let fn = Filename.concat dir.Dir.path base in - STbl.replace !files base fn; - STbl.replace !files_uncap (String.uncapitalize_ascii base) fn - ) dir.Dir.files - -let init ~auto_include l = - reset (); - dirs := List.rev_map Dir.create l; - List.iter prepend_add !dirs; - auto_include_callback := auto_include - -let remove_dir dir = - assert (not Config.merlin || Local_store.is_bound ()); - let new_dirs = List.filter (fun d -> Dir.path d <> dir) !dirs in - if List.compare_lengths new_dirs !dirs <> 0 then begin - reset (); - List.iter prepend_add new_dirs; - dirs := new_dirs - end - -(* General purpose version of function to add a new entry to load path: We only - add a basename to the cache if it is not already present in the cache, in - order to enforce left-to-right precedence. *) -let add dir = - assert (not Config.merlin || Local_store.is_bound ()); - List.iter - (fun base -> - let fn = Filename.concat dir.Dir.path base in - if not (STbl.mem !files base) then - STbl.replace !files base fn; - let ubase = String.uncapitalize_ascii base in - if not (STbl.mem !files_uncap ubase) then - STbl.replace !files_uncap ubase fn) - dir.Dir.files; - dirs := dir :: !dirs - -let append_dir = add - -let add_dir dir = add (Dir.create dir) - -(* Add the directory at the start of load path - so basenames are - unconditionally added. *) -let prepend_dir dir = - assert (not Config.merlin || Local_store.is_bound ()); - prepend_add dir; - dirs := !dirs @ [dir] - -let is_basename fn = Filename.basename fn = fn - -let auto_include_libs libs alert find_in_dir fn = - let scan (lib, lazy dir) = - let file = find_in_dir dir fn in - let alert_and_add_dir _ = - alert lib; - append_dir dir - in - Option.iter alert_and_add_dir file; - file - in - match List.find_map scan libs with - | Some base -> base - | None -> raise Not_found - -let auto_include_otherlibs = - (* Ensure directories are only ever scanned once *) - let expand = Misc.expand_directory Config.standard_library in - let otherlibs = - let read_lib lib = lazy (Dir.create (expand ("+" ^ lib))) in - List.map (fun lib -> (lib, read_lib lib)) ["dynlink"; "str"; "unix"] in - auto_include_libs otherlibs - -let find fn = - assert (not Config.merlin || Local_store.is_bound ()); - try - if is_basename fn && not !Sys.interactive then - STbl.find !files fn - else - Misc.find_in_path (get_paths ()) fn - with Not_found -> - !auto_include_callback Dir.find fn - -let find_uncap fn = - assert (not Config.merlin || Local_store.is_bound ()); - try - if is_basename fn && not !Sys.interactive then - STbl.find !files_uncap (String.uncapitalize_ascii fn) - else - Misc.find_in_path_uncap (get_paths ()) fn - with Not_found -> - let fn_uncap = String.uncapitalize_ascii fn in - !auto_include_callback Dir.find_uncap fn_uncap diff --git a/utils/load_path.mli b/utils/load_path.mli deleted file mode 100644 index fe3abaf95d..0000000000 --- a/utils/load_path.mli +++ /dev/null @@ -1,96 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jeremie Dimino, Jane Street Europe *) -(* *) -(* Copyright 2018 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Management of include directories. - - This module offers a high level interface to locating files in the - load path, which is constructed from [-I] command line flags and a few - other parameters. - - It makes the assumption that the contents of include directories - doesn't change during the execution of the compiler. -*) - -val add_dir : string -> unit -(** Add a directory to the end of the load path (i.e. at lowest priority.) *) - -val remove_dir : string -> unit -(** Remove a directory from the load path *) - -val reset : unit -> unit -(** Remove all directories *) - -module Dir : sig - type t - (** Represent one directory in the load path. *) - - val create : string -> t - - val path : t -> string - - val files : t -> string list - (** All the files in that directory. This doesn't include files in - sub-directories of this directory. *) - - val find : t -> string -> string option - (** [find dir fn] returns the full path to [fn] in [dir]. *) - - val find_uncap : t -> string -> string option - (** As {!find}, but search also for uncapitalized name, i.e. if name is - Foo.ml, either /path/Foo.ml or /path/foo.ml may be returned. *) -end - -type auto_include_callback = - (Dir.t -> string -> string option) -> string -> string -(** The type of callback functions on for [init ~auto_include] *) - -val no_auto_include : auto_include_callback -(** No automatic directory inclusion: misses in the load path raise [Not_found] - as normal. *) - -val init : auto_include:auto_include_callback -> string list -> unit -(** [init l] is the same as [reset (); List.iter add_dir (List.rev l)] *) - -val auto_include_otherlibs : - (string -> unit) -> auto_include_callback -(** [auto_include_otherlibs alert] is a callback function to be passed to - {!Load_path.init} and automatically adds [-I +lib] to the load path after - calling [alert lib]. *) - -val get_paths : unit -> string list -(** Return the list of directories passed to [add_dir] so far. *) - -val find : string -> string -(** Locate a file in the load path. Raise [Not_found] if the file - cannot be found. This function is optimized for the case where the - filename is a basename, i.e. doesn't contain a directory - separator. *) - -val find_uncap : string -> string -(** Same as [find], but search also for uncapitalized name, i.e. if - name is Foo.ml, allow /path/Foo.ml and /path/foo.ml to match. *) - -val[@deprecated] add : Dir.t -> unit -(** Old name for {!append_dir} *) - -val append_dir : Dir.t -> unit -(** [append_dir d] adds [d] to the end of the load path (i.e. at lowest - priority. *) - -val prepend_dir : Dir.t -> unit -(** [prepend_dir d] adds [d] to the start of the load path (i.e. at highest - priority. *) - -val get : unit -> Dir.t list -(** Same as [get_paths ()], except that it returns a [Dir.t list]. *)