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

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