package ppxlib

  1. Overview
  2. Docs
Standard infrastructure for ppx rewriters

Install 

dune-project
 Dependency

github.com Readme Changelog MIT License Edit opam file Versions (24)

Authors

  1. J
    Jane Street Group, LLC <opensource@janestreet.com>

Maintainers

  1. O
    opensource@janestreet.com

Sources

2e150834476230e99e48dfdf34c5e4a1ea6e749b.tar.gz
sha256=591d694609fed01783c9f360602e8660ae0e49eb33b7074c1317a261e00c6cdb
sha512=e15e956a114ab3f61dfa8f7eceed088082a116f3b6fc832b901729f611258af3b39bda748b2046b4886f429617aa64802f90e0520db82302443ecbba461970b2

doc/src/ppxlib.astlib/encoding_506.ml.html

Source file encoding_506.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
open Stdlib0

module Ext_name = struct
  let pstr_primitive_alias = "ppxlib.migration.pstr_primitive_alias_5_6"
  let psig_primitive_alias = "ppxlib.migration.psig_primitive_alias_5_6"
  let none = "ppxlib.migration.none_5_6"
  let primitive_alias = "ppxlib.migration.primitive_alias_5_6"
end

let invalid_encoding ~loc name = Error.invalid_encoding ~loc ~version:"5.6" name

module To_505 = struct
  open Ast_505.Asttypes
  open Ast_505.Parsetree

  let encode_typ_opt ~loc typ_opt =
    match typ_opt with
    | Some typ -> typ
    | None ->
        let ptyp_desc =
          Ptyp_extension ({ txt = Ext_name.none; loc }, PStr [])
        in
        { ptyp_desc; ptyp_loc = loc; ptyp_attributes = []; ptyp_loc_stack = [] }

  let decode_typ_opt ~loc core_type =
    match core_type.ptyp_desc with
    | Ptyp_extension ({ txt; _ }, payload) when String.equal txt Ext_name.none
      -> (
        match payload with
        | PStr [] -> None
        | _ -> invalid_encoding ~loc Ext_name.none)
    | _ -> Some core_type

  let encode_alias ~loc lident_loc =
    let attr_name = { txt = Ext_name.primitive_alias; loc } in
    let ident_expr =
      let pexp_desc = Pexp_ident lident_loc in
      { pexp_desc; pexp_loc = loc; pexp_attributes = []; pexp_loc_stack = [] }
    in
    let ident_stri =
      let pstr_desc = Pstr_eval (ident_expr, []) in
      { pstr_desc; pstr_loc = loc }
    in
    let attr_payload = PStr [ ident_stri ] in
    { attr_name; attr_payload; attr_loc = loc }

  let decode_alias ~loc attr_payload =
    match attr_payload with
    | PStr
        [ { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_ident ident; _ }, []) } ]
      ->
        ident
    | _ -> invalid_encoding ~loc Ext_name.primitive_alias

  let encode_primitive_alias ~loc pval_name typ_opt ident attrs =
    let pval_type = encode_typ_opt ~loc typ_opt in
    let alias_attr = encode_alias ~loc ident in
    let pval_attributes = alias_attr :: attrs in
    let vd =
      { pval_name; pval_type; pval_attributes; pval_loc = loc; pval_prim = [] }
    in
    let stri = { pstr_desc = Pstr_primitive vd; pstr_loc = loc } in
    PStr [ stri ]

  let decode_primitive_alias ~loc ~name payload =
    match payload with
    | PStr [ { pstr_desc = Pstr_primitive vd; _ } ] -> (
        let alias_attr_and_remainder =
          List.without_first vd.pval_attributes ~pred:(fun a ->
              String.equal a.attr_name.txt Ext_name.primitive_alias)
        in
        match alias_attr_and_remainder with
        | None -> invalid_encoding ~loc name
        | Some (alias_attr, remainder_attrs) ->
            let lident_loc = decode_alias ~loc alias_attr.attr_payload in
            let typ_opt = decode_typ_opt ~loc vd.pval_type in
            (vd.pval_name, typ_opt, lident_loc, remainder_attrs))
    | _ -> invalid_encoding ~loc name

  let encode_psig_primitive_alias ~loc pval_name typ_opt ident attrs =
    let payload = encode_primitive_alias ~loc pval_name typ_opt ident attrs in
    Psig_extension (({ txt = Ext_name.psig_primitive_alias; loc }, payload), [])

  let decode_psig_primitive_alias ~loc payload attrs =
    match attrs with
    | [] ->
        decode_primitive_alias ~loc ~name:Ext_name.psig_primitive_alias payload
    | _ -> invalid_encoding ~loc Ext_name.psig_primitive_alias

  let encode_pstr_primitive_alias ~loc pval_name typ_opt ident attrs =
    let payload = encode_primitive_alias ~loc pval_name typ_opt ident attrs in
    Pstr_extension (({ txt = Ext_name.pstr_primitive_alias; loc }, payload), [])

  let decode_pstr_primitive_alias ~loc payload attrs =
    match attrs with
    | [] ->
        decode_primitive_alias ~loc ~name:Ext_name.pstr_primitive_alias payload
    | _ -> invalid_encoding ~loc Ext_name.psig_primitive_alias
end