package ppx_monoid

  1. Overview
  2. Docs
package ppx_monoid
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file ppx_monoid.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
open Ppxlib

type ops =
  { empty : Location.t -> expression
  ; add   : Location.t -> expression
  }

let rec translate ops expr =
  let loc = expr.pexp_loc in
  match expr with
  | [%expr () ] ->
    ops.empty loc

  | [%expr while [%e? test_expr] do [%e? body_expr] done ] ->
    [%expr
      let body () = [%e translate ops body_expr]
      and test () = [%e test_expr] in
      let rec loop accum =
        if test () then
          loop ([%e ops.add loc] accum (body ()))
        else
          accum
      in
      loop [%e ops.empty loc]
    ]

  | [%expr for [%p? pat] = [%e? init] to [%e? final] do [%e? body] done ] ->
     [%expr
       let body [%p pat] = [%e translate ops body] in
       let limit = [%e final] in
       let rec loop i accum =
         if i > limit then accum
         else loop (i+1) ([%e ops.add expr.pexp_loc] accum (body i))
       in
       loop [%e init] [%e ops.empty expr.pexp_loc]
     ]

  | [%expr for [%p? pat] = [%e? init] downto [%e? final] do [%e? body] done ] ->
     [%expr
        let body [%p pat] = [%e translate ops body] in
        let limit = [%e final] in
        let rec loop i accum =
          if i < limit then accum
          else loop (i-1) ([%e ops.add expr.pexp_loc] accum (body i))
        in
        loop [%e init] [%e ops.empty expr.pexp_loc]
     ]

  | [%expr [%e? expr1] ; [%e? expr2] ] ->
     let expr1 = translate ops expr1 in
     let expr2 = translate ops expr2 in
     [%expr [%e ops.add expr.pexp_loc] [%e expr1] [%e expr2]]

  | [%expr if [%e? expr1] then [%e? expr2] else [%e? expr3]] ->
     let expr2 = translate ops expr2 in
     let expr3 = translate ops expr3 in
     [%expr if [%e expr1] then [%e expr2] else [%e expr3]]

  | [%expr if [%e? expr1] then [%e? expr2]] ->
     let expr2 = translate ops expr2 in
     [%expr if [%e expr1] then [%e expr2] else [%e ops.empty loc]]

  | { pexp_desc = Pexp_match (expr, cases) } ->
     let cases =
       List.map
         (fun ({pc_rhs} as c) ->
            {c with pc_rhs=translate ops pc_rhs})
         cases
     in
     { expr with pexp_desc = Pexp_match (expr, cases) }

  | { pexp_desc = Pexp_let (recflag, bindings, body) } ->
     let body = translate ops body in
     {expr with pexp_desc=Pexp_let (recflag, bindings, body)}

  | { pexp_desc = Pexp_open (decl, expr) } ->
     let expr = translate ops expr in
     {expr with pexp_desc=Pexp_open (decl, expr)}

  | { pexp_desc = Pexp_letmodule (name, module_expr, expr) } ->
     let expr = translate ops expr in
     {expr with pexp_desc=Pexp_letmodule (name, module_expr, expr)}

  | expr ->
    expr

let expander ~loc:_ ~path:_ ~arg payload =
  let ops =
    match arg with
    | None ->
      { empty = (fun loc -> {[%expr empty] with pexp_loc=loc})
      ; add   = (fun loc -> {[%expr (^^)] with pexp_loc=loc})
      }
    | Some prefix ->
      let with_prefix ident loc =
        Ast_helper.Exp.ident ~loc (Ast.{ txt = Longident.Ldot (prefix.txt, ident); loc })
      in
      { empty = with_prefix "empty"
      ; add   = with_prefix "^^"
      }
  in
  translate ops payload

let rules =
  ["concat"; "concatenate"; "monoid"] |> List.map begin fun name ->
    Ppxlib.Context_free.Rule.extension  @@
    Extension.declare_with_path_arg
      name
      Extension.Context.Expression
      Ast_pattern.(single_expr_payload __)
      expander
  end

let () =
  Driver.register_transformation
    ~rules
    "ppx-monoid"