Source file preprocess.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
open Core_kernel

let debug =
  match Sys.getenv "DEBUG_COMBY" with
  | exception Not_found -> false
  | _ -> true

let append_rule (module Parser : Types.Rule.S) rule parent_rule =
  let open Option in
  let rule =
    rule
    >>| Parser.create
    >>| function
    | Ok rule -> rule
    | Error e -> failwith @@ "Could not parse rule for alias entry:"^(Error.to_string_hum e)
  in
  match parent_rule, rule with
  | Some parent_rule, Some rule -> Some (parent_rule @ rule)
  | None, Some rule -> Some rule
  | Some parent_rule, None -> Some parent_rule
  | None, None -> None

let map_template (module Parser : Types.Rule.S) template pattern match_template rule parent_rule =
  let template' = String.substr_replace_all template ~pattern ~with_:match_template in
  if debug then Format.printf "Substituted: %s@." template';
  let rule' = append_rule (module Parser) rule parent_rule in
  template', rule'

let rec map_atom (rule : Types.Ast.expression list) f =
  let open Types.Ast in
  List.map rule ~f:(function
      | Equal (l, r) -> Equal (f l, f r)
      | Not_equal (l, r) -> Not_equal (f l, f r)
      | Match (e, l) ->
        Match (f e, List.map l ~f:(fun (a, l) -> (f a, map_atom l f)))
      | Rewrite (e, (l, r)) ->
        Rewrite (f e, (f l, f r))
      | t -> t)

let map_aliases
    (module Metasyntax : Metasyntax.S)
    (module External : External.S)
    template
    parent_rule =
  let module Parser = Rule.Make (Metasyntax) (External) in
  List.fold Metasyntax.aliases
    ~init:(template, parent_rule)
    ~f:(fun (template, parent_rule) Types.Metasyntax.{ pattern; match_template; rule } ->
        let template', parent_rule' =
          match String.substr_index template ~pattern with
          | None -> template, parent_rule
          | Some _ -> map_template (module Parser) template pattern match_template rule parent_rule
        in
        let parent_rule' =
          let open Option in
          parent_rule' >>| fun parent_rule' ->
          map_atom parent_rule' (function
              | Template t ->
                Template (Parser.Template.parse
                            (String.substr_replace_all
                               (Parser.Template.to_string t) ~pattern ~with_:match_template))
              | String s ->
                String (String.substr_replace_all s ~pattern ~with_:match_template))
        in
        template', parent_rule')