package comby-kernel

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

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

open Types.Ast

module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) = struct

  module Parser = Rule.Make (Metasyntax) (External)

  type spec = Specification.t
  [@@deriving sexp]

  type op =
    | And
    | Or
    | Not
  [@@deriving sexp]

  type exp =
    | Exp of op * exp list
    | Spec of spec
  [@@deriving sexp]

  type t = exp list
  [@@deriving sexp]

  let ignore p =
    p *> return ()

  let spaces = many @@ satisfy (function ' ' | '\n' | '\r' | '\t' -> true | _ -> false)
  let spaces1 = many1 @@ satisfy (function ' ' | '\n' | '\r' | '\t' -> true | _ -> false)

  let optional s = option () (ignore @@ string s)

  let chainl1 e op =
    let rec parse acc = (lift2 (fun f x -> f acc x) op e >>= parse) <|> return acc in
    e >>= fun init -> parse init

  let parens p = char '(' *> (p <|> return []) <* char ')'


  let template_parser until =
    choice
      [ (lift Parser.to_atom Parser.quoted_parser)
      ; (lift (fun v -> Parser.to_atom (String.of_char_list v)) (Omega_parser_helper.many1_till any_char until))
      ]

  let spec =
    let match_rewrite_parser =
      both
        (spaces *> template_parser (spaces *> string "->"))
        (option None (spaces *> string Syntax.arrow *> spaces *> template_parser (spaces1 *> string "where" *> spaces1)  >>| fun v -> Some v))
    in
    match_rewrite_parser >>= fun (match_template_atom, rewrite_template_atom) ->
    (option None (spaces1 *> Parser.parse >>| fun x -> Some x)) >>= fun rule ->
    let match_template = Sexplib.Sexp.to_string_hum (sexp_of_atom match_template_atom) in
    let rewrite_template =
      match rewrite_template_atom with
      | Some rewrite_template_atom -> Some (Sexplib.Sexp.to_string_hum (sexp_of_atom rewrite_template_atom))
      | None -> None
    in
    return [(Spec (Specification.{ match_template; rule; rewrite_template }))]

  let unop syntax exp_parser =
    choice (List.map ~f:string syntax) *> spaces *> exp_parser >>| fun exp -> [Exp (Not, exp)]

  let binop syntax op =
    spaces *> choice (List.map ~f:string syntax) *> spaces *> return (fun left right -> [Exp (op, left@right)])

  let exp_parser =
    fix (fun exp ->
        let exp_parser = fix (fun exp' -> parens exp <|> unop ["NOT"; "not"] exp' <|> spec) in
        let and_parser = chainl1 exp_parser @@ binop ["AND"; "and"] And in
        let seq_parser = chainl1 and_parser @@ binop ["OR"; "or"] Or in
        sep_by1 (spaces *> string Syntax.separator <* spaces) seq_parser >>| List.concat)

  let parser =
    spaces *> optional Syntax.separator *>
    exp_parser <* optional Syntax.separator <* spaces <* end_of_input

  let parse script =
    parse_string ~consume:All parser script

  let to_string exp =
    Sexplib.Sexp.to_string_hum (sexp_of_t exp)

end
OCaml

Innovation. Community. Security.