Skip to content

Upgrade from ocaml-migrate-parsetree to Ppxlib #14

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
OlivierNicole wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Upgrade from ocaml-migrate-parsetree to Ppxlib #14

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion dune-project
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,2 +1,2 @@
(lang dune 2.0)
(lang dune 3.1)
(name ppx_stage)
113 changes: 9 additions & 104 deletions ppx/binding.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,9 +1,5 @@
open Migrate_parsetree
open Ast_408

open Asttypes
open Parsetree
open Ast_helper
open Ppxlib
open Ppxlib.Ast_builder.Default

type binding_site = Binder of int | Context of int

Expand All @@ -30,7 +26,7 @@ and analyse_exp_desc env loc = function
| PStr [ {pstr_desc=Pstr_eval (e, _); _} ] ->
e
| _ ->
raise (Location.(Error (error ~loc ("[%e] expects an expression")))) in
raise (Location.(Error (Error.make ~sub:[] ~loc ("[%e] expects an expression")))) in
let h = env.fresh_hole () in
Hashtbl.add env.hole_table h (env.bindings, code);
Pexp_ident { txt = Lident ("," ^ string_of_int h); loc }
Expand Down Expand Up @@ -95,9 +91,8 @@ and analyse_exp_desc env loc = function
let env' = analyse_pat env pat in
Pexp_for (pat, analyse_exp env e1, analyse_exp env e2, dir, analyse_exp env' body)
(* several missing... *)


| _ -> raise (Location.(Error (error ~loc ("expression not supported in staged code"))))
| _ -> raise (Location.(Error (Error.make ~sub:[] ~loc ("expression not supported in staged code"))))

and analyse_exp_opt env = function
| None -> None
Expand All @@ -109,16 +104,16 @@ and analyse_pat env pat =

and analyse_pat_desc env loc = function
| Ppat_any -> env
| Ppat_var v -> analyse_pat_desc env loc (Ppat_alias (Pat.any (), v))
| Ppat_var v -> analyse_pat_desc env loc (Ppat_alias (ppat_any ~loc, v))
| Ppat_alias (pat, v) ->
let env = analyse_pat env pat in
{ env with bindings = IdentMap.add v.txt (env.fresh_binder ()) env.bindings }
| Ppat_constant _ -> env
| Ppat_interval _ -> env
| Ppat_tuple pats -> List.fold_left analyse_pat env pats
| Ppat_construct (_loc, None) -> env
| Ppat_construct (_loc, Some pat) -> analyse_pat env pat
| _ -> raise (Location.(Error (error ~loc ("pattern not supported in staged code"))))
| Ppat_construct (_loc, Some (_locs, pat)) -> analyse_pat env pat
| _ -> raise (Location.(Error (Error.make ~sub:[] ~loc ("pattern not supported in staged code"))))

and analyse_case env {pc_lhs; pc_guard; pc_rhs} =
let env' = analyse_pat env pc_lhs in
Expand All @@ -131,7 +126,7 @@ and analyse_attributes = function
| {attr_payload=PStr []; _} :: rest ->
analyse_attributes rest
| {attr_name={loc;txt}; _} :: _ ->
raise (Location.(Error (error ~loc ("attribute " ^ txt ^ " not supported in staged code"))))
raise (Location.(Error (Error.make ~sub:[] ~loc ("attribute " ^ txt ^ " not supported in staged code"))))


let analyse_binders (context : int IdentMap.t) (e : expression) :
Expand All @@ -150,94 +145,4 @@ let analyse_binders (context : int IdentMap.t) (e : expression) :
e', hole_table



open Ast_mapper
type substitutable =
| SubstContext of int
| SubstHole of int

let substitute_holes (e : expression) (f : substitutable -> expression) =
let expr mapper pexp =
match pexp.pexp_desc with
| Pexp_ident { txt = Lident v; loc = _ } ->
let id () = int_of_string (String.sub v 1 (String.length v - 1)) in
(match v.[0] with
| ',' -> f (SubstHole (id ()))
| ';' -> f (SubstContext (id ()))
| _ -> pexp)
| _ -> default_mapper.expr mapper pexp in
let mapper = { default_mapper with expr } in
mapper.expr mapper e


let module_remapper f =
let rename (id : Longident.t Location.loc) : Longident.t Location.loc =
let rec go : Longident.t -> Longident.t = function
| Lident id -> Lident (f id)
| Ldot (id, x) -> Ldot (go id, x)
| Lapply (idF, idX) -> Lapply (go idF, go idX) in
{id with txt = go id.txt} in
let open Parsetree in
let open Ast_mapper in
let rec expr mapper pexp =
let pexp_desc = match pexp.pexp_desc with
| Pexp_ident id ->
Pexp_ident (rename id)
| Pexp_construct (id, e) ->
Pexp_construct (rename id, expr_opt mapper e)
| Pexp_record (fs, e) ->
let fs = List.map (fun (id, e) -> (rename id, expr mapper e)) fs in
Pexp_record (fs, expr_opt mapper e)
| Pexp_field (e, f) ->
Pexp_field (expr mapper e, rename f)
| Pexp_setfield (e, f, x) ->
Pexp_setfield (expr mapper e, rename f, expr mapper x)
| Pexp_new id ->
Pexp_new (rename id)
| Pexp_open (md, e) ->
Pexp_open ({md with popen_expr = module_expr mapper md.popen_expr },
expr mapper e)
| _ -> (default_mapper.expr mapper pexp).pexp_desc in
{ pexp with pexp_desc }
and expr_opt mapper = function
| None -> None
| Some e -> Some (expr mapper e)
and typ mapper ptyp =
let ptyp_desc = match ptyp.ptyp_desc with
| Ptyp_constr (id, tys) ->
Ptyp_constr (rename id, List.map (typ mapper) tys)
| Ptyp_class (id, tys) ->
Ptyp_class (rename id, List.map (typ mapper) tys)
| _ -> (default_mapper.typ mapper ptyp).ptyp_desc in
{ ptyp with ptyp_desc }
and pat mapper ppat =
let ppat_desc = match ppat.ppat_desc with
| Ppat_construct (id, pat) ->
Ppat_construct (rename id, pat_opt mapper pat)
| Ppat_record (fs, flag) ->
let fs = List.map (fun (id, p) -> (rename id, pat mapper p)) fs in
Ppat_record (fs, flag)
| Ppat_type id ->
Ppat_type (rename id)
| Ppat_open (id, p) ->
Ppat_open (rename id, pat mapper p)
| _ -> (default_mapper.pat mapper ppat).ppat_desc in
{ ppat with ppat_desc }
and pat_opt mapper = function
| None -> None
| Some p -> Some (pat mapper p)
and module_type mapper pmty =
let pmty_desc = match pmty.pmty_desc with
| Pmty_ident id -> Pmty_ident (rename id)
| Pmty_alias id -> Pmty_alias (rename id)
| _ -> (default_mapper.module_type mapper pmty).pmty_desc in
{ pmty with pmty_desc }
and open_description _mapper op =
{ op with popen_expr = rename op.popen_expr }
and module_expr mapper pmod =
let pmod_desc = match pmod.pmod_desc with
| Pmod_ident id -> Pmod_ident (rename id)
| _ -> (default_mapper.module_expr mapper pmod).pmod_desc in
{ pmod with pmod_desc }
in
{ default_mapper with expr; typ; pat; module_type; open_description; module_expr }
let module_remapper = Ppx_stage.Internal.module_remapper
5 changes: 2 additions & 3 deletions ppx/dune
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,5 @@
(public_name ppx_stage.ppx)
(kind ppx_rewriter)
(ppx_runtime_libraries ppx_stage.runtime-lib)
(preprocess
(pps ppx_tools_versioned.metaquot_408))
(libraries ocaml-migrate-parsetree ppx_tools_versioned ppx_stage.runtime-lib))
(preprocess (pps ppxlib.metaquot))
(libraries ppx_stage.runtime-lib ppxlib))
Loading