package ppx_parser

  1. Overview
  2. Docs

Source file parser.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
150
151
152
153
154
155
156
157
158
159
160
161
open Ppxlib
open Util

type match_ctxt = Peek | Call

let try_with_fail_in ~loc var_pat fn_ident cont_expr =
  [%expr
    let [%p var_pat] =
      try [%e fn_ident] ppx____parser____stream____
      with Stream.Failure -> [%e raise_err_exn ~loc]
    in
    [%e cont_expr]]

let expand_list_elem ~loc cont_expr = function
  | {
      ppat_desc =
        Ppat_alias
          ( { ppat_desc = Ppat_var { txt = call; _ }; ppat_loc = call_loc; _ },
            as_label );
      ppat_loc = as_loc;
      _;
    } ->
      let var_pat = Ast_builder.Default.ppat_var ~loc:as_loc as_label in
      let fn_ident =
        Ast_builder.Default.pexp_ident ~loc:call_loc { txt = Lident call; loc }
      in
      try_with_fail_in ~loc var_pat fn_ident cont_expr
  | {
      ppat_desc = Ppat_extension ({ txt = "let" | "l"; _ }, payload);
      ppat_loc;
      _;
    } ->
      let e, pat = Let.expand_let_payload_tl ~loc:ppat_loc payload in
      [%expr
        let [%p pat] = [%e e] in
        [%e cont_expr]]
  | pat ->
      [%expr
        match [%e peek ~loc] with
        | [%p some_pat ~loc pat] -> [%e junk ~loc cont_expr]
        | _ -> [%e raise_err_exn ~loc]]

let rec expand_list_seq_tl ~loc result_expr = function
  | [%pat? []] -> result_expr
  | [%pat? [%p? hd] :: [%p? tl]] ->
      let cont_expr = expand_list_seq_tl ~loc result_expr tl in
      expand_list_elem ~loc:hd.ppat_loc cont_expr hd
  | _ -> Err.err_expr_node ~loc "Expected a list of patterns."

let expand_list_seq ~loc ctxt { pc_lhs; pc_guard; pc_rhs } to_match_expr
    other_cases =
  let prepend_to_cases case =
    match other_cases with
    | [] ->
        [
          case;
          { pc_lhs = [%pat? _]; pc_guard = None; pc_rhs = raise_fail_exn ~loc };
        ]
    | _ -> case :: other_cases
  in
  let bind_var_w_call pat on_match_expr =
    let pat = some_pat ~loc:pat.ppat_loc pat in
    let on_no_match_expr =
      match other_cases with
      | [] -> [%expr raise Stream.Failure]
      | { pc_lhs = [%pat? _]; pc_guard = None; pc_rhs } :: [] -> pc_rhs
      | _ -> Ast_builder.Default.pexp_match ~loc to_match_expr other_cases
    in
    let match_case = { pc_lhs = pat; pc_guard; pc_rhs = on_match_expr } in
    let no_match_case =
      { pc_lhs = [%pat? _]; pc_guard = None; pc_rhs = on_no_match_expr }
    in
    [ match_case; no_match_case ]
  in
  match pc_lhs with
  | [%pat? []] ->
      let pat = [%pat? _] in
      let case = { pc_lhs = pat; pc_guard; pc_rhs } in
      let cases =
        match pc_guard with None -> case :: [] | _ -> prepend_to_cases case
      in
      (ctxt, to_match_expr, cases)
  | [%pat? [%p? hd] :: [%p? tl]] -> (
      let on_match_expr = expand_list_seq_tl ~loc pc_rhs tl in
      match hd with
      | {
       ppat_desc = Ppat_extension ({ txt = "let" | "l"; _ }, payload);
       ppat_loc;
       _;
      } ->
          let to_match_expr, pat =
            Let.expand_let_payload_hd ~loc:ppat_loc payload
          in
          let cases = bind_var_w_call pat on_match_expr in
          (Call, to_match_expr, cases)
      | {
       ppat_desc =
         Ppat_alias
           ( { ppat_desc = Ppat_var { txt = call; _ }; ppat_loc = call_loc; _ },
             as_label );
       ppat_loc = as_loc;
       _;
      } ->
          let var_pat = Ast_builder.Default.ppat_var ~loc:as_loc as_label in
          let fn_ident =
            Ast_builder.Default.pexp_ident ~loc:call_loc
              { txt = Lident call; loc }
          in
          let to_match_expr =
            [%expr
              try Some ([%e fn_ident] ppx____parser____stream____)
              with Stream.Failure -> None]
          in
          let cases = bind_var_w_call var_pat on_match_expr in
          (Call, to_match_expr, cases)
      | pat -> (
          let pat = some_pat ~loc:pat.ppat_loc pat in
          let on_match_expr = junk ~loc on_match_expr in
          let match_case = { pc_lhs = pat; pc_guard; pc_rhs = on_match_expr } in
          match ctxt with
          | Call ->
              let on_no_match_expr =
                Ast_builder.Default.pexp_match ~loc to_match_expr other_cases
              in
              let no_match_case =
                {
                  pc_lhs = [%pat? _];
                  pc_guard = None;
                  pc_rhs = on_no_match_expr;
                }
              in
              let to_match_expr = peek ~loc in
              let cases = [ match_case; no_match_case ] in
              (Peek, to_match_expr, cases)
          | Peek ->
              let cases = prepend_to_cases match_case in
              (ctxt, to_match_expr, cases)))
  | _ ->
      ( ctxt,
        Err.err_expr_node ~loc:pc_lhs.ppat_loc
          "Expected a case where the left-hand side is a list of patterns.",
        other_cases )

let expand_function_cases ~loc cases =
  let rec iter ctxt cases =
    match cases with
    | [] -> (ctxt, peek ~loc, cases)
    | case :: cases_rest ->
        let ctxt, to_match_expr, cases = iter ctxt cases_rest in
        expand_list_seq ~loc:case.pc_lhs.ppat_loc ctxt case to_match_expr cases
  in
  iter Peek cases

let expand_function ~loc cases =
  let _, to_match_expr, cases = expand_function_cases ~loc cases in
  let match_expr = Ast_builder.Default.pexp_match ~loc to_match_expr cases in
  [%expr function ppx____parser____stream____ -> [%e match_expr]]

let expand_function_from_ctxt ~ctxt cases =
  let loc = Expansion_context.Extension.extension_point_loc ctxt in
  expand_function ~loc cases