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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
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"
  let pexp_hole = "ppxlib.migration.pexp_hole"
  let pmod_hole = "ppxlib.migration.pmod_hole"
end

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

module type AST = sig
  type payload
  type expression_desc
  type module_expr_desc

  module Construct : sig
    val empty_payload : payload
    val pexp_extension_desc : string Location.loc -> payload -> expression_desc
    val pmod_extension_desc : string Location.loc -> payload -> module_expr_desc
  end
end

module Ast_505_arg = struct
  include Ast_505.Parsetree

  module Construct = struct
    let empty_payload = PStr []
    let pexp_extension_desc ext p = Pexp_extension (ext, p)
    let pmod_extension_desc ext m = Pmod_extension (ext, m)
  end
end

module Ast_502_arg = struct
  include Ast_502.Parsetree

  module Construct = struct
    let empty_payload = PStr []
    let pexp_extension_desc ext p = Pexp_extension (ext, p)
    let pmod_extension_desc ext m = Pmod_extension (ext, m)
  end
end

(** The X module is only for things we wish to expose to users to pattern-match
    or construct. Anything else can go directly in [To_505]. *)
module X (Ast : AST) = struct
  let encode_pexp_hole ~loc =
    let ext = Asttypes.{ txt = Ext_name.pexp_hole; loc } in
    Ast.Construct.pexp_extension_desc ext Ast.Construct.empty_payload

  let encode_pmod_hole ~loc =
    let ext = Asttypes.{ txt = Ext_name.pmod_hole; loc } in
    Ast.Construct.pmod_extension_desc ext Ast.Construct.empty_payload
end

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

  include X (Ast_505_arg)
end

module To_502 = X (Ast_502_arg)