Permalink
Browse files

Merge pull request #915 from objmagic/more-pprintast-fix

more -dsource bug fix
  • Loading branch information...
alainfrisch committed Dec 19, 2016
2 parents 7e2f27b + 0d848ad commit 6998d171e41c9039899b6d6b80ba5860543c8700
Showing with 131 additions and 80 deletions.
  1. +6 −5 .depend
  2. +2 −0 Changes
  3. +2 −2 Makefile.shared
  4. +1 −0 debugger/Makefile
  5. +2 −1 otherlibs/dynlink/Makefile
  6. +51 −0 parsing/ast_helper.ml
  7. +9 −0 parsing/ast_helper.mli
  8. +1 −51 parsing/parser.mly
  9. +46 −19 parsing/pprintast.ml
  10. +11 −2 testsuite/tests/parsetree/source.ml
View
11 .depend
@@ -48,12 +48,13 @@ utils/warnings.cmx : utils/misc.cmx utils/warnings.cmi
utils/warnings.cmi :
parsing/ast_helper.cmo : parsing/parsetree.cmi parsing/longident.cmi \
parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi \
parsing/ast_helper.cmi
parsing/syntaxerr.cmi parsing/ast_helper.cmi
parsing/ast_helper.cmx : parsing/parsetree.cmi parsing/longident.cmx \
parsing/location.cmx parsing/docstrings.cmx parsing/asttypes.cmi \
parsing/ast_helper.cmi
parsing/syntaxerr.cmx parsing/ast_helper.cmi
parsing/ast_helper.cmi : parsing/parsetree.cmi parsing/longident.cmi \
parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi
parsing/location.cmi parsing/docstrings.cmi \
parsing/syntaxerr.cmi parsing/asttypes.cmi
parsing/ast_invariants.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \
parsing/longident.cmi parsing/builtin_attributes.cmi parsing/asttypes.cmi \
parsing/ast_iterator.cmi parsing/ast_invariants.cmi
@@ -136,10 +137,10 @@ parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \
parsing/asttypes.cmi
parsing/pprintast.cmo : parsing/parsetree.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \
parsing/pprintast.cmi
parsing/ast_helper.cmi parsing/pprintast.cmi
parsing/pprintast.cmx : parsing/parsetree.cmi utils/misc.cmx \
parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \
parsing/pprintast.cmi
parsing/ast_helper.cmx parsing/pprintast.cmi
parsing/pprintast.cmi : parsing/parsetree.cmi
parsing/printast.cmo : parsing/parsetree.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \
View
@@ -162,6 +162,8 @@ Next version (4.05.0):
list in .cmti files + avoid rebuilding cmi_info record when creating
.cmti files
(Alain Frisch, report by Daniel Bunzli, review by Jeremie Dimino)
- GPR#915: fix -dsource (pprintast.ml) bugs
(Runhang Li, review by Alain Frisch)
### Bug fixes
View
@@ -51,8 +51,8 @@ UTILS=utils/config.cmo utils/misc.cmo \
utils/targetint.cmo
PARSING=parsing/location.cmo parsing/longident.cmo \
parsing/docstrings.cmo parsing/ast_helper.cmo \
parsing/syntaxerr.cmo parsing/parser.cmo \
parsing/docstrings.cmo parsing/syntaxerr.cmo \
parsing/ast_helper.cmo parsing/parser.cmo \
parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \
parsing/pprintast.cmo \
parsing/ast_mapper.cmo parsing/ast_iterator.cmo parsing/attr_helper.cmo \
View
@@ -41,6 +41,7 @@ OTHEROBJS=\
../utils/consistbl.cmo ../utils/warnings.cmo \
../utils/terminfo.cmo \
../parsing/location.cmo ../parsing/longident.cmo ../parsing/docstrings.cmo \
../parsing/syntaxerr.cmo \
../parsing/ast_helper.cmo ../parsing/ast_mapper.cmo \
../parsing/ast_iterator.cmo ../parsing/attr_helper.cmo \
../parsing/builtin_attributes.cmo \
@@ -45,7 +45,8 @@ COMPILEROBJS=\
../../utils/terminfo.cmo ../../utils/warnings.cmo \
../../parsing/asttypes.cmi \
../../parsing/location.cmo ../../parsing/longident.cmo \
../../parsing/docstrings.cmo ../../parsing/ast_helper.cmo \
../../parsing/docstrings.cmo ../../parsing/syntaxerr.cmo \
../../parsing/ast_helper.cmo \
../../parsing/ast_mapper.cmo ../../parsing/ast_iterator.cmo \
../../parsing/attr_helper.cmo \
../../parsing/builtin_attributes.cmo \
View
@@ -65,6 +65,57 @@ module Typ = struct
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 (fun (s, attrs, t) -> (s, attrs, loop t)) 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 =
function
| Rtag(label,attrs,flag,lst) ->
Rtag(label,attrs,flag,List.map loop lst)
| Rinherit t ->
Rinherit (loop t)
in
loop t
end
module Pat = struct
View
@@ -73,6 +73,15 @@ module Typ :
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 *)
View
@@ -219,64 +219,14 @@ let exp_of_label lbl pos =
let pat_of_label lbl pos =
mkpat (Ppat_var (mkrhs (Longident.last lbl) pos))
let check_variable vl loc v =
if List.mem v vl then
raise Syntaxerr.(Error(Variable_in_scope(loc,v)))
let varify_constructors var_names t =
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 = 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 (fun (s, attrs, t) -> (s, attrs, loop t)) 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 =
function
| Rtag(label,attrs,flag,lst) ->
Rtag(label,attrs,flag,List.map loop lst)
| Rinherit t ->
Rinherit (loop t)
in
loop t
let mk_newtypes newtypes exp =
List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))
newtypes exp
let wrap_type_annotation newtypes core_type body =
let exp = mkexp(Pexp_constraint(body,core_type)) in
let exp = mk_newtypes newtypes exp in
(exp, ghtyp(Ptyp_poly(newtypes,varify_constructors newtypes core_type)))
(exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type)))
let wrap_exp_attrs body (ext, attrs) =
(* todo: keep exact location for the entire attribute *)
View
@@ -26,6 +26,7 @@ open Format
open Location
open Longident
open Parsetree
open Ast_helper
let prefix_symbols = [ '!'; '?'; '~' ] ;;
let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
@@ -47,7 +48,7 @@ let fixity_of_string = function
let view_fixity_of_exp = function
| {pexp_desc = Pexp_ident {txt=Lident l;_};_} -> fixity_of_string l
| _ -> `Normal ;;
| _ -> `Normal
let is_infix = function | `Infix _ -> true | _ -> false
@@ -1081,25 +1082,51 @@ and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e
| _ -> pp f "=@;%a" (expression ctxt) x
in
let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in
let is_desugared_gadt p e =
let gadt_pattern =
match p.ppat_desc with
| Ppat_constraint({ppat_desc=Ppat_var _} as pat,
{ptyp_desc=Ptyp_poly (args_tyvars, rt)}) ->
Some (pat, args_tyvars, rt)
| _ -> None in
let rec gadt_exp tyvars e =
match e.pexp_desc with
| Pexp_newtype (tyvar, e) -> gadt_exp (tyvar :: tyvars) e
| Pexp_constraint (e, ct) -> Some (List.rev tyvars, e, ct)
| _ -> None in
let gadt_exp = gadt_exp [] e in
match gadt_pattern, gadt_exp with
| Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct)
when tyvars_str pt_tyvars = tyvars_str e_tyvars ->
let ety = Typ.varify_constructors e_tyvars e_ct in
if ety = pt_ct then
Some (p, pt_tyvars, e_ct, e) else None
| _ -> None in
if x.pexp_attributes <> []
then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
else match (x.pexp_desc,p.ppat_desc) with
| ( _ , Ppat_constraint( p ,ty)) -> (* special case for the first*)
begin match ty.ptyp_desc with
| Ptyp_poly _ ->
pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p
(core_type ctxt) ty (expression ctxt) x
| _ ->
pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p
(core_type ctxt) ty (expression ctxt) x
end
| Pexp_constraint (e,t1),Ppat_var {txt;_} ->
pp f "%a@;:@ %a@;=@;%a" protect_ident txt
(core_type ctxt) t1 (expression ctxt) e
| (_, Ppat_var _) ->
pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x
| _ ->
pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else
match is_desugared_gadt p x with
| Some (p, tyvars, ct, e) -> begin
pp f "%a@;: type@;%a.%a@;=@;%a"
(simple_pattern ctxt) p (list pp_print_string ~sep:"@;")
(tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e
end
| None -> begin
match (x.pexp_desc,p.ppat_desc) with
| ( _ , Ppat_constraint( p ,ty)) -> (* special case for the first*)
begin match ty.ptyp_desc with
| Ptyp_poly _ ->
pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p
(core_type ctxt) ty (expression ctxt) x
| _ ->
pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p
(core_type ctxt) ty (expression ctxt) x
end
| (_, Ppat_var _) ->
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) =
@@ -7238,13 +7238,11 @@ class id = [%exp]
let _ = fun (x : < x : int >) y z -> (y :> 'a), (x :> 'a), (z :> 'a);;
(* - : (< x : int > as 'a) -> 'a -> 'a * 'a = <fun> *)
(*
class ['a] c () = object
method f = (new c (): int c)
end and ['a] d () = object
inherit ['a] c ()
end;;
*)
(* PR#7329 Pattern open *)
let _ =
@@ -7254,3 +7252,14 @@ let _ =
let h = function M.[] | M.[a] | M.(a::q) -> () in
let i = function M.[||] | M.[|x|] -> true | _ -> false in
()
class ['a] c () = object
constraint 'a = < .. > -> unit
method m = (fun x -> () : 'a)
end
let f: type a'.a' = assert false
let foo : type a' b'. a' -> b' = fun a -> assert false
let foo : type t' . t' = fun (type t') -> (assert false : t')
let foo : 't . 't = fun (type t) -> (assert false : t)
let foo : type a' b' c' t. a' -> b' -> c' -> t = fun a b c -> assert false

0 comments on commit 6998d17

Please sign in to comment.