Reading Camlp4, part 11: syntax extensions

In this final (?) post in my series on Camlp4, I want at last to cover syntax extensions. A nontrivial syntax extension involves almost all the topics we have previously covered, so it seems fitting that we treat them last.

Extending grammars

In the post on parsing we covered Camlp4 grammars but stopped short of explaining how to extend them. Well, this is not completely true: we used the EXTEND form to extend an empty grammar, and we can also use it to extend non-empty grammars. We saw a small example of this when implementing quotations, where we extended the JSON grammar with a new json_eoi entry (which refered to an entry in the original grammar). Rules and levels may also be added to existing entries, and rules may be deleted.

Let’s look at a complete syntax extension, which demonstrates modifying Camlp4’s OCaml grammar. The purpose of the extension is to change the precedence of the method call operator # to make “method chaining” read better. For example, if the foo method returns an object, you can write

  obj#foo "bar" #baz 

to call the baz method, rather than needing

  (obj#foo "bar")#baz 

(I originally wrote this for use with the jQuery binding for ocamljs; method chaining is common with jQuery.)

Here is the extension:

  open Camlp4 
  
  module Id : Sig.Id = 
  struct 
    let name = "pa_jquery" 
    let version = "0.1" 
  end 
  
  module Make (Syntax : Sig.Camlp4Syntax) = 
  struct 
    open Sig 
    include Syntax 
  
    DELETE_RULE Gram expr: SELF; "#"; label END; 
  
    EXTEND Gram 
      expr: BEFORE "apply" 
        [ "#" LEFTA 
          [ e = SELF; "#"; lab = label -> 
              <:expr< $e$ # $lab$ >> ] 
        ]; 
    END 
  end 
  
  module M = Register.OCamlSyntaxExtension(Id)(Make) 

To make sense of a syntax extension it’s helpful to refer to Camlp4OCamlRevisedParser.ml (which defines the revised syntax grammar) and Camlp4OCamlParser.ml (which defines the original syntax as an extension of the revised syntax). There we see that the # operator is parsed in the expr entry, in a level called ”.” (which includes other dereferencing operators), and that this level appears below the apply level, which parses function application. Recall from the parsing post that operators in lower levels bind more tightly. So to get the effect we want, we need to move the # rule above the apply level in the grammar.

First we delete the rule from its original location: DELETE_RULE takes the grammar, the entry, and the symbols on the left-hand side of the rule, followed by END; you don’t have to say in what level it appears. Then we add the rule at a new location: we create a new level # containing the rule from the original grammar, and add it before the level named apply.

There are several ways to specify where a level is inserted: BEFORE level and AFTER level put it before or after some other level; LEVEL level adds rules to an existing level (you will be warned but not stopped from changing the label or associativity of the level); FIRST and LAST put the level before or after all other levels. If you don’t specify, rules are added to the topmost level in the entry. The resulting grammar works just as if you had given it all at once, making the insertions in the specified places. (However, it is not very clear from the code how ordering works when inserting rules into an existing level; it is perhaps best not to rely on the order of rules in a level anyway.)

Finally we register the extension. The Make argument to OCamlSyntaxExtension returns a Sig.Camlp4Syntax for some reason (in Register.ml it is just ignored) so we include Syntax to provide it.

(The complete code for this example is here.)

Transforming the AST

Let’s do a slightly more complicated example involving some transformation of the parsed AST. It often comes up that we want to let-bind the value of an expression to a name, trapping exceptions, then evaluate the body of the let outside the scope of the exception handler. This is a bit painful to write in stock OCaml; we can only straightforwardly express trapping exceptions in the whole let expression:

  try let x = e1 in e2 
  with e -> h 

A nice alternative is to use thunks to delay the evaluation of the body, doing it outside the scope of the try/with:

  (try let x = e1 in fun () -> e2 
   with e -> fun () -> h)() 

(We must thunkify the exception handler to make the types work out.) This is simple enough to do by hand, but let’s give it some syntactic sugar:

  let try x = e1 in e2 
  with e -> h 

which should expand to the thunkified version above. (The idea and syntax are taken from Martin Jambon’s micmatch extension.)

Let’s look at the existing rules in Camlp4OCamlRevisedParser.ml for let and try to get an idea of how to parse the let/try form:

  [ "let"; r = opt_rec; bi = binding; "in"; x = SELF -> 
      <:expr< let $rec:r$ $bi$ in $x$ >> 
  ... 
  | "try"; e = sequence; "with"; a = match_case -> 
      <:expr< try $mksequence' _loc e$ with [ $a$ ] >> 

For let, the opt_rec entry parses an optional rec keyword (we see there is a special antiquotation for interpolating rec). Binding parses a group of bindings separated by and. SELF is just expr. For try, sequence is a sequence of expressions separated by ;, and match_case is a group of match cases separated by |. (These entries are both a little different in the original syntax, to account for the different semicolon rules and the [] delimiters around the match cases.) Recall that Camlp4OCamlRevisedParser.ml uses the revised syntax quotations, so we have [] around the match cases. The call to mksequence' just wraps a do {} around a sequence if necessary; more on this below.

The parsing rule we want is a combination of these. Here is the extension:

  EXTEND Gram 
    expr: LEVEL "top" [ 
      [ "let"; "try"; r = opt_rec; bi = binding; "in"; 
        e = sequence; "with"; a = match_case -> 
          let a = 
            List.map 
              (function 
                 | <:match_case< $p$ when $w$ -> $e$ >> -> 
                     <:match_case< 
                       $p$ when $w$ -> fun () -> $e$ 
                     >> 
                 | mc -> mc) 
              (Ast.list_of_match_case a []) in 
          <:expr< 
            (try let $rec:r$ $bi$ in fun () -> do { $e$ } 
             with [ $list:a$ ])() 
          >> 
      ] 
    ]; 
  END 

We put rec after try (following micmatch), which is a little weird , but if we put it before we would need to look ahead to disambiguate `let` from `let try`; once we parse `opt_rec` we are committed to one rule or the other ; instead we could start the rule "let"; r = opt_rec; "try", which has no ambiguity with the ordinary let rule because the "let"; opt_rec prefix is factored out; the parser doesn’t choose between the rules until it tries to parse try. After in we parse sequence rather than SELF; this seems like a good choice because there is a with to end the sequence.

Now, to transform the AST, we map over the match cases. The match_case entry returns a list of cases separated by Ast.McOr; we call list_of_match_case to get an ordinary list. For each case, we match the pattern, when clause, and expression on the right-hand side (these are packaged in an Ast.McArr, where the when clause field is Ast.ExNil if there is no when clause), and return it with the expression thunkified. Then we return the whole let inside try, with the body sequence thunkified.

We have to add a do {} around the body, creating an Ast.ExSeq node, because that’s what is expected by Camlp4Ast2OCamlAst.ml—recall from the filters post that the Camlp4 AST is translated to an OCaml AST and marshalled to the compiler. If we forget this (and “we” often forget these idiosyncrasies) then we get the error ”expr; expr: not allowed here, use do {...} or [|...|] to surround them”, which is pretty helpful as these errors go.

(The complete code for this example is here.)

Extending pattern matching

As a final example, let’s extend OCaml’s pattern syntax. In the quotations post we noted that JSON quotations in a pattern are not very useful, because we would usually like a pattern to match even if the fields of an object come in a different order or there are extra fields. To keep the code short let’s abstract the problem a little and consider matching association lists: if we write a match case

  | alist [ "foo", x; "bar", y ] -> e 

we would like it to match association lists with "foo" and "bar" keys, in any order, with any extra pairs in the list. Our translation looks like this:

  | __pa_alist_patt_1 when 
      (match ((try Some (List.assoc "foo" __pa_alist_patt_1) 
               with | Not_found -> None), 
              (try Some (List.assoc "bar" __pa_alist_patt_1) 
               with | Not_found -> None)) 
       with 
       | (Some x, Some y) -> true 
       | _ -> false) 
      -> 
      (match ((try Some (List.assoc "foo" __pa_alist_patt_1) 
               with | Not_found -> None), 
              (try Some (List.assoc "bar" __pa_alist_patt_1) 
               with | Not_found -> None)) 
       with 
       | (Some x, Some y) -> e 
       | _ -> assert false) 

This might seem overcomplicated, and it is true that we could simplify it for this case. But the built-in pattern syntax is complicated, and it is tricky handling all the cases to make things work smoothly; the strategy that produces the code above will handle some (but not all) of the complications. (We’ll consider some improvements below.)

The basic idea is that when we come to an alist we replace it with a new fresh name, then do further matching in a when clause, so if it fails we can continue to the next case by returning false. In the when clause we look up the keys, putting them in options, then match on the options; we handle nested patterns (to the right of a key) by embedding them in the when clause match. The when clause match also binds variables appearing in the original pattern, so they are available to the when clause of the original case (if there is one). Finally, we do the whole thing over again in the match case body to provide bindings to the original body.

In order to implement this we’ll use both a syntax extension and a filter. The reason is that we’d like to extend the patt entry, but to do the AST transformation we sketched above we need to transform match_cases. We could replace the match_case part of the parser as well but that seems needlessly hairy, and generally when writing a syntax extension we’d like to touch as little of the parser as possible so it interoperates well with other extensions.

First, here is the syntax extension:

  EXTEND Gram 
    patt: LEVEL "simple" 
    [[ 
       "alist"; "["; 
         l = 
           LIST0 
             [ e = expr LEVEL "simple"; ","; 
               p = patt LEVEL "simple" -> 
                 Ast.PaOlbi (_loc, "", p, e) ] 
             SEP ";"; 
       "]" -> 
         <:patt< $uid:"alist"$ $Ast.paSem_of_list l$ >> 
    ]]; 
  END 

We extend the simple level of the patt entry, which parses primitive patterns. Inside alist [] we parse a list of expr / patt pairs; we parse expr at the simple level or else it would parse the whole pair as an expr, and the same for patt just in case. Then we return the pair of expression and pattern in an Ast.PaOlbi (ordinarily used for optional argument defaults in function definitions). Why? Well, we need to return something of type patt, but we need somehow to get the expr to our filter, and this is the only patt constructor that holds an expr. (As an alternative we could parse a patt instead of an expr, but then we’d need to translate it to an expr at the point we use it.) Finally we return the list wrapped in a data constructor so we can recognize it easily in the filter; because it is lower-case, we can be sure that “alist” is not the identifier of a real data constructor.

Now let’s look at the filter. First, some helper functions:

  let fresh = 
    let id = ref 0 in 
    fun () -> 
      incr id; 
      "__pa_alist_patt_"  ^ string_of_int !id 
 
  let expr_tup_of_list _loc = function 
    | [] -> <:expr< () >> 
    | [ v ] -> v 
    | vs -> <:expr< $tup:Ast.exCom_of_list vs$ >> 
 
  let patt_tup_of_list _loc = function 
    | [] -> <:patt< () >> 
    | [ p ] -> p 
    | ps -> <:patt< $tup:Ast.paCom_of_list ps$ >> 

We have a function to generate fresh names, a function to turn a list of expressions into a tuple, and a similar function for patterns. The reason we need these latter two is that a tuple with 0 or 1 elements is not allowed by Camlp4Ast2OCamlAst.ml (the empty “tuple” is actually a special identifier in the Camlp4 AST). Next, the main rewrite function:

  let rewrite _loc p w e = 
    let k = ref (fun s f -> s) in 

The function takes the parts of an Ast.McArr (that is, a match case). We’re going to map over the pattern p, building up a function k as we encounter nested alist forms. We want to generate the same matching code in the when clause and the body, so k is parameterized with an expression in case of success (the original when clause or the body) and in case of failure (false or assert false). We will build k from the inside out, starting with a function that just returns the success expression.

    let map = 
      object 
        inherit Ast.map as super 
 
        method patt p = 
          match super#patt p with 
            | <:patt< $uid:"alist"$ $l$ >> -> 
                let id = fresh () in 
                let l = 
                  List.map 
                    (function 
                       | Ast.PaOlbi (_, _, p, e) -> p, e 
                       | _ -> assert false) 
                    (Ast.list_of_patt l []) in 
                let vs = 
                  List.map 
                    (fun (_, e) -> 
                       <:expr< 
                         try Some (List.assoc $e$ $lid:id$) 
                         with Not_found -> None 
                       >>) 
                    l in 
                let ps = 
                  List.map 
                    (fun (p, _) -> <:patt< Some $p$ >>) 
                    l in 
                let k' = !k in 
                k := 
                  (fun s f -> 
                     <:expr< 
                       match $expr_tup_of_list _loc vs$ with 
                         | $patt_tup_of_list _loc ps$ -> $k' s f$ 
                         | _ -> $f$ 
                     >>); 
                <:patt< $lid:id$ >> 
            | p -> p 
      end in 

The Ast.map object provides methods to map each syntactic class of the AST, along with default implementations which return the node unchanged. We extend it to walk over the pattern, leaving it unchanged except when we come to our special alist constructor. In that case we generate a fresh name, which we return as the value of the function. Then we extract the expr / patt pairs and map them to try Some (List.assoc ... expressions and Some patterns. Finally we extend k by matching all the expressions against all the patterns; if the match succeeds we call the previous k, otherwise the failure expression. Since we build k from the inside out, we transform subpatterns first (by matching over super#patt p).

    let p = map#patt p in 
    let w = match w with <:expr< >> -> <:expr< true >> | _ -> w in 
    let w = !k w <:expr< false >> in 
    let e = !k e <:expr< assert false >> in 
    <:match_case< $p$ when $w$ -> $e$ >> 

We call map#patt on p to replace special alist constructor nodes with fresh names and build up k, then call the resulting k on the when clause (if there is no when clause we replace it with true) and body, and finally return the result as a match_case, completing the rewrite function.

  let filter = 
    let map = 
      object 
        inherit Ast.map as super 
 
        method match_case mc = 
          match super#match_case mc with 
            | <:match_case@_loc< $p$ when $w$ -> $e$ >> -> 
                rewrite _loc p w e 
            | e -> e 
      end in 
    map#str_item 
 
  let _ = AstFilters.register_str_item_filter filter 

We extend Ast.map again to call the rewrite function on each match_case, then register the resulting filter.

The code above handles when clauses and nested alist patterns, and interacts properly with ordinary OCaml patterns. However, it completely falls down on nested pattern alternatives. If we write

match x with 
  | alist [ "foo", f ] 
  | alist [ "fooz", f ] -> e 

we get this mess:

  | __pa_alist_patt_1 | __pa_alist_patt_2 when 
      (match try Some (List.assoc "fooz" __pa_alist_patt_2) 
             with | Not_found -> None 
       with 
       | Some f -> 
           (match try Some (List.assoc "foo" __pa_alist_patt_1) 
                  with | Not_found -> None 
            with 
            | Some f -> true 
            | _ -> false) 
       | _ -> false) 
      -> 
      ... (* the same mess for the body *) 

The first problem is that both arms of an alternative must bind the same names, but we have replaced them with two different fresh names. The second problem is that we have blindly treated alternative alist patterns as being nested one inside the other. A solution to both these problems is to split nested alternatives into separate cases, at the cost of duplicating the when clause and body in each.

Jeremy Yallop’s patterns framework (see here for an update that works with OCaml 3.12.0) allows multiple pattern extensions to coexist, and provides some common facilities to make them easier to write. In particular it splits nested alternatives into separate cases. Another deficiency in the code above is that it duplicates the match expression (built in k) in the when clause and body. This can be avoided by computing the body within the when clause, setting a reference, and dereferencing it in the body. However, the reference must be bound outside the match_case to be visible both in the when clause and the body, so this approach must transform each AST node that contains match_cases in order to bind the refs in the right place. The patterns framework handles this as well.

(The complete code for this example is here. A version using the patterns framework is here.)

Reading Camlp4, part 10: custom lexers

As a final modification to our running JSON quotation example, I want to repair a problem noted in the first post—that the default lexer does not match the JSON spec—and in doing so demonstrate the use of custom lexers with Camlp4 grammars. We’ll parse UTF8-encoded Javascript using the ulex library.

To use a custom lexer, we need to pass a module matching the Lexer signature (in camlp4/Camlp4/Sig.ml) to Camlp4.PreCast.MakeGram. (Recall that we get back an empty grammar which we then extend with parser entries. ) Let’s look at the signature and its subsignatures, and our implementation of each:

Error

  module type Error = sig 
    type t 
    exception E of t 
    val to_string : t -> string 
    val print : Format.formatter -> t -> unit 
  end 

First we have a module for packaging up an exception so it can be handled generically (in particular it may be registered with Camlp4.ErrorHandler for common printing and handling). We have simple exception needs so we give a simple implementation:

  module Error = 
  struct 
    type t = string 
    exception E of string 
    let print = Format.pp_print_string 
    let to_string x = x 
  end 
  let _ = let module M = Camlp4.ErrorHandler.Register(Error) in () 

Token

Next we have a module defining the tokens our lexer supports:

  module type Token = sig 
    module Loc : Loc 
  
    type t 
  
    val to_string : t -> string 
    val print : Format.formatter -> t -> unit 
    val match_keyword : string -> t -> bool 
    val extract_string : t -> string 
  
    module Filter : ... (* see below *) 
    module Error : Error 
  end 

The type t represents a token. This can be anything we like (in particular it does not need to be a variant with arms KEYWORD, EOI, etc. although that is the conventional representation), so long as we provide the specified functions to convert it to a string, print it to a formatter, determine if it matches a string keyword (recall that we can use literal strings in grammars; this function is called to see if the next token matches a literal string), and extract a string representation of it (called when you bind a variable to a token in a grammar—e.g. n = NUMBER). Here’s our implementation:

  type token = 
    | KEYWORD  of string 
    | NUMBER   of string 
    | STRING   of string 
    | ANTIQUOT of string * string 
    | EOI 
 
  module Token = 
  struct 
    type t = token 
  
    let to_string t = 
      let sf = Printf.sprintf in 
      match t with 
        | KEYWORD s       -> sf "KEYWORD %S" s 
        | NUMBER s        -> sf "NUMBER %s" s 
        | STRING s        -> sf "STRING \"%s\"" s 
        | ANTIQUOT (n, s) -> sf "ANTIQUOT %s: %S" n s 
        | EOI             -> sf "EOI" 
  
    let print ppf x = Format.pp_print_string ppf (to_string x) 
  
    let match_keyword kwd = 
      function 
        | KEYWORD kwd' when kwd = kwd' -> true 
        | _ -> false 
  
    let extract_string = 
      function 
        | KEYWORD s | NUMBER s | STRING s -> s 
        | tok -> 
            invalid_arg 
              ("Cannot extract a string from this token: " ^ 
                 to_string tok) 
 
    module Loc = Camlp4.PreCast.Loc 
    module Error = Error 
    module Filter = ... (* see below *) 
  end 

Not much to it. KEYWORD covers true, false, null, and punctuation; NUMBER and STRING are JSON numbers and strings; as we saw last time antiquotations are returned in ANTIQUOT; finally we signal the end of the input with EOI.

Filter

  module Filter : sig 
    type token_filter = 
      (t * Loc.t) Stream.t -> (t * Loc.t) Stream.t 
 
    type t 
 
    val mk : (string -> bool) -> t 
    val define_filter : t -> (token_filter -> token_filter) -> unit 
    val filter : t -> token_filter 
    val keyword_added : t -> string -> bool -> unit 
    val keyword_removed : t -> string -> unit 
  end; 

The Filter module provides filters over token streams. We don’t have a need for it in the JSON example, but it’s interesting to see how it is implemented in the default lexer and used in the OCaml parser. The argument to mk is a function indicating whether a string should be treated as a keyword (i.e. the literal string is used in the grammar), and the default lexer uses it to filter the token stream to convert identifiers into keywords. If we wanted the JSON parser to be extensible, we would need to take this into account; instead we’ll just stub out the functions:

  module Filter = 
  struct 
    type token_filter = 
      (t * Loc.t) Stream.t -> (t * Loc.t) Stream.t 
 
    type t = unit 
 
    let mk _ = () 
    let filter _ strm = strm 
    let define_filter _ _ = () 
    let keyword_added _ _ _ = () 
    let keyword_removed _ _ = () 
  end 

Lexer

Finally we have Lexer, which packages up the other modules and provides the actual lexing function. The lexing function takes an initial location and a character stream, and returns a stream of token and location pairs:

module type Lexer = sig 
  module Loc : Loc 
  module Token : Token with module Loc = Loc 
  module Error : Error 
 
  val mk : 
    unit -> 
    (Loc.t -> char Stream.t -> (Token.t * Loc.t) Stream.t) 
end 

I don’t want to go through the whole lexing function; it is not very interesting. But here is the main loop:

let rec token c = lexer 
  | eof -> EOI 
 
  | newline -> next_line c; token c c.lexbuf 
  | blank+ -> token c c.lexbuf 
 
  | '-'? ['0'-'9']+ ('.' ['0'-'9']* )? 
      (('e'|'E')('+'|'-')?(['0'-'9']+))? -> 
        NUMBER (L.utf8_lexeme c.lexbuf) 
 
  | [ "{}[]:," ] | "null" | "true" | "false" -> 
      KEYWORD (L.utf8_lexeme c.lexbuf) 
 
  | '"' -> 
      set_start_loc c; 
      string c c.lexbuf; 
      STRING (get_stored_string c) 
 
  | "$" -> 
      set_start_loc c; 
      c.enc := Ulexing.Latin1; 
      let aq = antiquot c lexbuf in 
      c.enc := Ulexing.Utf8; 
      aq 
 
  | _ -> illegal c 

The lexer syntax is an extension provided by ulex; the effect is similar to ocamllex. The lexer needs to keep track of the current location and return it along with the token (next_line advances the current location; set_start_loc is for when a token spans multiple ulex lexemes). The lexer also needs to parse antiquotations, taking into account nested quotations within them.

(I think it is not actually necessary to lex JSON as UTF8. The only place that non-ASCII characters can appear is in a string. To lex a string we just accumulate characters until we see a double-quote, which cannot appear as part of a multibyte character. So it would work just as well to accumulate bytes. I am no Unicode expert though. This example was extracted from the Javascript parser in jslib, where I think UTF8 must be taken into account.)

Hooking up the lexer

There are a handful of changes we need to make to call the custom lexer:

In Jq_parser we make the grammar with the custom lexer module, and open it so the token constructors are available; we also replace the INT and FLOAT cases with just NUMBER; for the other cases we used the same token constructor names as the default lexer so we don’t need to change anything.

  open Jq_lexer 
 
  module Gram = Camlp4.PreCast.MakeGram(Jq_lexer) 
 
  ... 
      | n = NUMBER -> Jq_number (float_of_string n) 

In Jq_quotations we have Camlp4.PreCast open (so references to Ast in the <:expr< >> quotations resolve), so EOI is Camlp4.PreCast.EOI; we want Jq_lexer.EOI, so we need to write it explicitly:

  json_eoi: [[ x = Jq_parser.json; `Jq_lexer.EOI -> x ]]; 

(Recall that the backtick lets us match a constructor directly; for some reason we can’t module-qualify EOI without it.)

That’s it.

I want to finish off this series next time by covering grammar extension, with an example OCaml syntax extension.

(You can find the complete code for this example here.)

Reading Camlp4, part 9: implementing antiquotations

In this post I want to complicate the JSON quotation library from the previous post by adding antiquotations.

AST with antiquotations

In order to support antiquotations we will need to make some changes to the AST. Here is the new AST type:

  type t = 
      ... (* base types same as before *) 
    | Jq_array  of t 
    | Jq_object of t 
  
    | Jq_colon  of t * t 
    | Jq_comma  of t * t 
    | Jq_nil 
  
    | Jq_Ant    of Loc.t * string 

Let’s first consider Jq_Ant. Antiquotations $tag:body$ are returned from the lexer as an ANTIQUOT token containing the (possibly empty) tag and the entire body (including nested quotations/antiquotations) as a string. In the parser, we deal only with the JSON AST, so we can’t really do anything with an antiquotation but return it to the caller (wrapped in a Jq_Ant).

The lifting functions generated by Camlp4MetaGenerator treat Jq_Ant (and any other constructor ending in Ant) specially: instead of

  | Jq_Ant (loc, s) -> 
      <:expr< Jq_Ant ($meta_loc loc$, $meta_string s$) >> 

they have

  | Jq_Ant (loc, s) -> ExAnt (loc, s) 

Instead of lifting the constructor, they translate it directly to ExAnt (or PaAnt, depending on the context). We don’t otherwise have locations in our AST, but Jq_Ant must take a Loc.t argument because ExAnt does. Later, when we walk the OCaml AST expanding antiquotations, it will be convenient to have them as ExAnt nodes rather than lifted Jq_Ant nodes.

In addition to Jq_Ant, we have new Jq_nil, Jq_comma, and Jq_colon constructors, and we have replaced the lists in Jq_array and Jq_object with just t. The idea here is that in an antiquotation in an array, e.g.

  <:json< [ 1, true, $x$, "foo" ] >> 

we would like to be able to substitute any number of elements (including zero) into the array in place of x. If Jq_array took a list, we could substitute exactly one element only. So instead we build a tree out of Jq_comma and Jq_nil constructors; at any point in the tree we can substitute zero (Jq_nil), one (any other t constructor), or more than one (a Jq_comma subtree) elements. We recover a list by taking the fringe of the final tree. (In the Jq_ast module there are functions t_of_list and list_of_t which convert between these representations.) For objects, we use Jq_colon to associate a name with a value, then build a tree of name/value pairs the same way.

While this AST meets the need, it is now possible to have ill-formed ASTs, e.g. a bare Jq_nil, or a Jq_object where the elements are not Jq_colon pairs, or where the first argument of Jq_colon is not a Jq_string. This is annoying, but it is hard to see how to avoid it without complicating the AST and making it more difficult to use antiquotations.

Parsing antiquotations

Here is the updated parser:

  EXTEND Gram 
    json: [[ 
        ... (* base types same as before *) 
  
      | `ANTIQUOT 
          (""|"bool"|"int"|"flo"|"str"|"list"|"alist" as n, s) -> 
            Jq_Ant (_loc, n ^ ":" ^ s) 
  
      | "["; es = SELF; "]" -> Jq_array es 
      | "{"; kvs = SELF; "}" -> Jq_object kvs 
  
      | e1 = SELF; ","; e2 = SELF -> Jq_comma (e1, e2) 
      | -> Jq_nil 
 
      | e1 = SELF; ":"; e2 = SELF -> Jq_colon (e1, e2)  
    ]]; 
  END 

We want to support several kinds of antiquotations: For individual elements, $x$ (where x is a t), or $bool:x$, $int:x$, $flo:x$, or $str:x$ (where x is an OCaml bool, int, float, or string); for these latter cases we need to wrap x in the appropriate t constructor. For lists of elements, $list:x$ where x is a t list, and $alist:x$ where x is a (string * t) list; for these we need to convert x to the Jq_comma / Jq_nil representation above. But in the parser all we do is return a Jq_Ant containing the tag and body of the ANTIQUOT token. (We return it in a single string separated by : because only one string argument is provided in ExAnt.)

It is the parser which controls where antiquotations are allowed, by providing a case for ANTIQUOT in a particular entry, and which tags are allowed in an entry. In this example we have only one entry, so we allow any supported antiquotation anywhere a JSON expression is allowed, but you can see in the OCaml parsers that the acceptable antiquotations can be context-sensitive, and the interpretation of the same antiquotation can vary according to the context (e.g. different conversions may be needed).

For arrays and objects, we parse SELF in place of the list. The cases for Jq_comma and Jq_nil produce the tree representation, and the case for Jq_colon allows name/value pairs. Recall that a token or keyword is preferred over the empty string, so the Jq_nil case matches only when none of the others do. In particular, the quotation <:json< >> parses to Jq_nil.

We can see that not only is the AST rather free, but so is the parser: it will parse strings which are not well-formed JSON, like <:json< 1, 2 >> or <json:< "foo" : true >>. We lose safety, since a mistake may produce an ill-formed AST, but gain convenience, since we may want to substitute these fragments in antiquotations. As an alternative, we could have a more restrictive parser (e.g. no commas allowed at the json entry), and provide different quotations for different contexts (e.g. <:json_list< >>, allowing commas) for use with antiquotations. For this small language I think it is not worth it.

Expanding antiquotations

To expand antiquotations, we take a pass over the OCaml AST we got from lifting the JSON AST; look for ExAst nodes; parse them as OCaml; then apply the appropriate conversion according to the antiquotation tag. To walk the AST we extend the Ast.map object (generated with the Camlp4FoldGenerator filter) so we don’t need a bunch of boilerplate cases which return the AST unchanged. Here’s the code:

  module AQ = Syntax.AntiquotSyntax 
  
  let destruct_aq s = 
    let pos = String.index s ':' in 
    let len = String.length s in 
    let name = String.sub s 0 pos 
    and code = String.sub s (pos + 1) (len - pos - 1) in 
    name, code 
  
  let aq_expander = 
  object 
    inherit Ast.map as super 
    method expr = 
      function 
        | Ast.ExAnt (_loc, s) -> 
            let n, c = destruct_aq s in 
            let e = AQ.parse_expr _loc c in 
            begin match n with 
              | "bool" -> <:expr< Jq_ast.Jq_bool $e$ >> 
              | "int" -> 
                  <:expr< Jq_ast.Jq_number (float_of_int $e$) >> 
              | "flo" -> <:expr< Jq_ast.Jq_number $e$ >> 
              | "str" -> <:expr< Jq_ast.Jq_string $e$ >> 
              | "list" -> <:expr< Jq_ast.t_of_list $e$ >> 
              | "alist" -> 
                  <:expr< 
                    Jq_ast.t_of_list 
                      (List.map 
                        (fun (k, v) -> 
                          Jq_ast.Jq_colon (Jq_ast.Jq_string k, v)) 
                        $e$) 
                  >> 
              | _ -> e 
            end 
        | e -> super#expr e 
    method patt = 
      function 
        | Ast.PaAnt (_loc, s) -> 
            let _, c = destruct_aq s in 
            AQ.parse_patt _loc c 
        | p -> super#patt p 
  end 

When we find an antiquotation, we unpack the tag and contents (with destruct_aq), parse it using the host syntax (given by Syntax.AntiquotSyntax from Camlp4.PreCast, which might be either the original or revised syntax depending which modules are loaded), then insert conversions depending on the tag. Conversions don’t make sense in a pattern context, so for patterns we just return the parsed antiquotation.

Finally we hook into the quotation machinery, mostly as before:

let parse_quot_string loc s = 
  let q = !Camlp4_config.antiquotations in 
  Camlp4_config.antiquotations := true; 
  let res = Jq_parser.Gram.parse_string json_eoi loc s in 
  Camlp4_config.antiquotations := q; 
  res 
 
let expand_expr loc _ s = 
  let ast = parse_quot_string loc s in 
  let meta_ast = Jq_ast.MetaExpr.meta_t loc ast in 
  aq_expander#expr meta_ast 
 
;; 
 
Q.add "json" Q.DynAst.expr_tag expand_expr; 

Before parsing a quotation we set a flag, which is checked by the lexer, to allow antiquotations; the flag is initially false, so antiquotations appearing outside a quotation won’t be parsed. After lifting the JSON AST to an OCaml AST, we run the result through the antiquotation expander.

For concreteness, let’s follow the life of a quotation as it is parsed and expanded. Say we begin with

  <:json< [ 1, $int:x$ ] >> 

After parsing:

  Jq_array (Jq_comma (Jq_number 1., Jq_Ant (_loc, "int:x"))) 

After lifting:

  <:expr< 
    Jq_array (Jq_comma (Jq_number 1., $ExAnt (_loc, "int:x")$)) 
  >> 

After expanding:

  <:expr< 
    Jq_array (Jq_comma (Jq_number 1., Jq_number (float_of_int x))) 
  >> 

Nested quotations

Let’s see that again with a nested quotation:

  <:json< $<:json< 1 >>$ >> 

After parsing:

  Jq_Ant (_loc, "<:json< 1 >>") 

After lifting:

  ExAnt (_loc, "<:json< 1 >>") 

After expanding (during which we parse and expand "<:json< 1 >>" to <:expr< Jq_number 1. >>):

  <:expr< Jq_number 1. >> 

A wise man once said “The string is a stark data structure and everywhere it is passed there is much duplication of process.” So it is with Camlp4 quotations: each nested quotation is re-parsed; each quotation implementation must deal with parsing host-language antiquotation strings; and the lexer for each implementation must lex antiquotations and nested quotations. (Since we used the default lexer we didn’t have to worry about this, but see the next post.) It would be nice to have more support from Camlp4. On the other hand, while what happens at runtime seems baroque, the code above is relatively straightforward, and since we work with strings we can use any parser technology we like.

It has not been much (marginal) trouble to handle quotations in pattern contexts, but they are not tremendously useful. The problem is that we normally don’t care about the order of the fields in a JSON object, or if there are extra fields; we would like to write

  match x with 
    | <:json< { 
        "foo" : $foo$ 
      } >> -> ... (* do something with foo *) 

and have it work wherever the foo field is in the object. This is a more complicated job than just lifting the JSON AST. For an alternative approach to processing JSON using a list-comprehension syntax, see json_compr, an example I wrote for the upcoming metaprogramming tutorial at CUFP. For a fancier JSON DSL (including the ability to induct a type description from a bunch of examples!), see Julien Verlauget’s jsonpat. And for a framework to extend OCaml’s pattern-matching syntax, see Jeremy Yallop’s ocaml-patterns.

Next time we will see how to use a custom lexer with a Camlp4 grammar.

(You can find the complete code for this example here.)