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;
;;

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.