backtracking-templates.ml

(* Backtracking templates.  See
<http://lists.canonical.org/pipermail/kragen-tol/2012-April/000951.html>
for more details.

This version doesn’t yet implement template parsing or a reasonable
way to feed in template parameters (e.g. JSON).

I decided to do this entirely with polymorphic variants to familiarize
myself with them, and without any type declarations, but I did cheat a
little bit: in one place I use an ordinary list instead of faking one
up with `Cons and `Nil variants.

 *)

(* The Maybe monad. *)
let maybe v1 thunk = match v1 with
  | (`Fail _) as f -> f
  | `Ok v -> thunk v
;;

let rec get n = function 
  | `Binding(n2, v, t) -> if n = n2 then `Ok v else get n t
  | `Nil -> `Fail("Could not find variable "^n)
;;

let rec dump = function
  | `Lit x -> x
  | `Var x -> "$"^x
  | `Concat(x, y) -> (dump x)^(dump y)
  | `Alt(x, y) -> "<{>"^(dump x)^"<|>"^(dump y)^"<}>"
  | `Ifeq(x, y) -> "<if "^(dump x)^" == "^(dump y)^">"
  | `Loop(var, body, comma) ->
    "<{><@"^var^">"^(dump body)^"<,>"^(dump comma)^"<}>"
;;

(* XXX use List.append, bozo *)
let rec augment env = function
  | `Nil -> env
  | `Binding(n, v, t) -> `Binding(n, v, augment env t)
;;

let concat a b = `Ok(a^b) ;;

let rec eval env = function
  | `Lit x -> `Ok x
  | `Var x -> maybe (get x env) (function
      | `String s -> `Ok s
      | `Dictlist _ -> `Fail("Expected string for "^x^" but got list")
  )
  | `Concat(x, y) -> 
    maybe (eval env x) (fun xv -> maybe (eval env y) (concat xv))
  | `Alt(x, y) -> (match (eval env x) with
      | `Fail _ -> eval env y
      | (`Ok _) as v -> v
  )
  | (`Ifeq(x, y)) as cond ->
    if (eval env x) = (eval env y) 
    then `Ok "" 
    else `Fail("Condition failed: "^dump(cond))
  | `Loop(varname, body, comma) ->
    maybe (get varname env) (function
      | `String _ -> `Fail("Expected list for "^varname^" but got string")
      | `Dictlist d ->
        let rec iterate = function
          | [] -> `Fail("empty list in "^varname)
          | [dict] -> eval (augment env dict) body
          | dict :: dicts ->
            maybe (eval (augment env dict) (`Concat(body, comma)))
              (fun first -> maybe (iterate dicts) (concat first))
        in iterate d
    )
;;

let bibtemplate = 
  `Concat(
  `Alt(`Concat(`Concat((`Lit "In "), (`Var "booktitle")), `Lit "."), `Lit ""),
  `Alt(
    `Concat(`Concat(`Lit " ", `Var "month"), `
      Concat(`Concat(`Lit " ", `Var "year"), `Lit ".")), 
    `Lit ""))
;;

let bibentry = 
`Binding
  ("year", `String "1381",
   `Binding
     ("month", `String "Farvardin",
      `Binding
        ("booktitle", `String "Proceedings of Tehran Academy of Linguistics",
         `Nil)))
;;



let demo template entry = 
  print_endline((dump template)^": "^match eval entry template with
    | `Ok output -> output
    | `Fail message -> message)
;;

let bibloop = `Concat(`Lit " ",
                      `Concat(`Loop("author", `Var "name", `Lit ", "), 
                              `Lit ". ")) ;;
let bibtemplate2 = `Concat(bibtemplate, bibloop) ;;

let bibentry2 = 
`Binding
  ("author",
   `Dictlist
     [`Binding ("name", `String "Taher Marzian", `Nil);
      `Binding ("name", `String "Shahriar Afshar", `Nil)],
   bibentry)
;;

demo bibtemplate bibentry;
demo bibtemplate bibentry2;
demo bibtemplate2 bibentry;
demo bibtemplate2 bibentry2;
;;

Here are some of the type errors I got while writing this, what they meant, and how they helped me.

  demo bibentry2 bibtemplate2 ;;
       ^^^^^^^^^
Error: This expression has type
         [> `Binding of
              string *
              [> `Dictlist of
                   [> `Binding of string * [> `String of string ] * [> `Nil ] ]
                   list ] *
              [> `Binding of
                   string * [> `String of string ] *
                   [> `Binding of
                        string * [> `String of string ] *
                        [> `Binding of
                             string * [> `String of string ] * [> `Nil ] ] ] ] ]
       but an expression was expected of type
         [< `Alt of 'a * 'a
          | `Concat of 'a * 'a
          | `Ifeq of 'a * 'a
          | `Lit of string
          | `Loop of string * 'a * 'a
          | `Var of string
          > `Concat `Ifeq ]
         as 'a
       The second variant type does not allow tag(s) `Binding

That meant I got the argument order backwards.

$ ocaml ~/devel/inexorable-misc/bttemplates.ml
File "/home/kragen/devel/inexorable-misc/bttemplates.ml", line 114, characters 0-25:
Warning 10: this expression should have type unit.

(That was because I forgot to put in print_endline, so I was computing a string and discarding it.)

Characters 79-120:
  `Binding("author", `Dictlist [`Binding("name", `String "Taher Marzian", `Nil); `Binding("name", "Shahriar Afshar", `Nil)], `Nil) ;;
                                                                                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This expression has type [> `Binding of string * string * [> `Nil ] ]
       but an expression was expected of type
         [> `Binding of string * [> `String of string ] * [> `Nil ] ]
       Types for tag `Binding are incompatible

That one I only got because I was using a list instead of a polymorphic variant for the contents of the Dictlist`. It's complaining that I forgot the String` on the second one.

Characters 38-64:
  let demo () = (dump bibexample)^": "^(eval bibentry bibexample) ;;
                                       ^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This expression has type [ `Fail of string | `Ok of string ]
       but an expression was expected of type string

It's telling me that I'm trying to directly concatenate the success/failure value from eval with a string, and I can't do that.

Characters 0-4:
  eval `Binding("booktitle", "Proceedings of Your Mother", `Nil) bibexample ;;
  ^^^^
Error: This function is applied to too many arguments;
maybe you forgot a `;'

It's telling me that I need parens outside of ``Binding`.

eval (Binding("booktitle", "Proceedings of Your Mother",Nil)) bibexample ;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This expression has type [> Binding of string * string * [>Nil ] ]
but an expression was expected of type
[< Binding of string * ([<Dictlist of
([< Binding of string * 'b * 'c |Nil ] as 'c) list &
'd
| String of 'e & string ] as 'b) * 'a |Nil
> Binding ] as 'a Types for tagBinding are incompatible

It's saying that I forgot to put `` `String `` before the title of the hypothetical book.

Characters 5-46:
dump (Concat(Lit "In "), (Var "booktitle"));; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This expression has type [>Concat of [> Lit of string ] ] * [>Var of string ]
but an expression was expected of type
[< Alt of 'a * 'a |Concat of 'a * 'a
| Ifeq of 'a * 'a |Lit of string
| Loop of string * 'a * 'a |Var of string ]
as 'a

It's telling me that I'm passing a tuple, because I didn't put parens around the two arguments to `` `Concat ``.

                                        Characters 478-781:

......(let rec iterate = function
| [] -> Fail("empty list in "^varname) | [dict] -> render (augment env dict) body | dict :: dicts -> maybe (render (augment env dict) (Concat(body, comma)))
(fun first -> maybe (iterate dicts) (concat first))
in iterate)
Error: This expression has type
([< Binding of string * string * 'a |Nil ] as 'a) list ->
[ Fail of string |Ok of string ]
but an expression was expected of type string -> [> `Fail of string ]

This was a bit of a puzzler. It turns out that the bug was that elsewhere, `eval` was returning the result of a variable lookup directly, whether it was successful or failing. Since `eval` returns `` `Ok of string `` sometimes, OCaml concluded that variable lookups must also be returning that, so when we try to call iterate with a list of dicts, it complains that we're calling it with a string. Even after that, though:

                                                      Characters 97-106:
    | `String s -> s
      ^^^^^^^^^

Error: This pattern matches values of type
[< Dictlist of 'a |String of 'b ]
but a pattern was expected which matches values of type
[> Fail of string |Ok of 'c ]
The first variant type does not allow tag(s) Fail,Ok

I was handling the case where a variable lookup erroneously found a list instead of a string, but I had forgotten to handle the case where a variable lookup didn't find anything.

                                        Characters 154-161:
  maybe (render env x) (fun xv -> maybe (render env y) ((^)xv))
                                                       ^^^^^^^

Error: This expression has type string -> string
but an expression was expected of type string -> [> `Fail of string ]

Right. You can't just concatenate with `^`; you have to concatenate and succeed. This was the origin of the function `concat`. Earlier, though:

  maybe (render env x) (fun xv -> maybe (render env y) (^)xv)
                                  ^^^^^

Error: This function is applied to too many arguments;
maybe you forgot a `;'

No, I forgot a `()`.

    Characters 103-135:
| `Nil -> `Fail "Could not find variable "^n
          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Error: This expression has type [> `Fail of string ]
but an expression was expected of type string

That means I need parens around the arguments to `` `Fail ``, because of relative precedence.

Actually, one of the more fascinating experiences was once I got the code to typecheck, I still found a bug by looking at the inferred type:

 let rec render env = function
  | `Lit x -> `Ok x
  | `Var x -> maybe (get x env) (function
      | `String s -> s
      | `Dictlist _ -> `Fail("Expected string for "^x^" but got list")
  )
  | `Concat(x, y) -> 
    maybe (render env x) (fun xv -> maybe (render env y) (concat xv))
  | `Alt(x, y) -> (match (render env x) with
      | `Fail _ -> render env y
      | (`Ok _) as v -> v
  )
  | (`Ifeq(x, y)) as cond ->
    if (render env x) = (render env y) 
    then `Ok "" 
    else `Fail("Condition failed: "^dump(cond))
  | `Loop(varname, body, comma) ->
    maybe (get varname env) (function
      | `String _ -> `Fail("Expected list for "^varname^" but got string")
      | `Dictlist d ->
        let rec iterate = function
          | [] -> `Fail("empty list in "^varname)
          | [dict] -> render (augment env dict) body
          | dict :: dicts ->
            maybe (render (augment env dict) (`Concat(body, comma)))
              (fun first -> maybe (iterate dicts) (concat first))
        in iterate d
    )
;;

                                                        val render :
  ([< `Binding of
        string *
        ([< `Dictlist of
              ([< `Binding of string * 'b * 'c | `Nil ] as 'c) list &
              'd
          | `String of 'e & [ `Fail of string | `Ok of string ] ]
         as 'b) *
        'a
    | `Nil
    > `Binding ]
   as 'a) ->
  ([< `Alt of 'f * 'f
    | `Concat of 'f * 'f
    | `Ifeq of 'f * 'f
    | `Lit of string
    | `Loop of string * 'f * 'f
    | `Var of string
    > `Concat `Ifeq ]
   as 'f) ->
  [ `Fail of string | `Ok of string ] = <fun>

Where it's saying ``String of 'e & [ Fail of string | Ok of string ] ]`, it's saying that it expects the variables in the `Binding` to be defined as either Dictlist or String, but the contents of the String should be `[ `Fail of string | `Ok of string ]`, which was clearly wrong. I changed `| `String s -> s` to `| `String s -> `Ok s`, which fixed the bug.

I haven't found any bugs yet in the code by running it. But running it has been kind of difficult.

http://ideone.com/TGqua has a live version of the program, which you can edit and run.