1 files changed, 151 insertions, 0 deletions
diff --git a/lib/render/template.ml b/lib/render/template.ml
new file mode 100644
index 0000000..7efa92b
--- /dev/null
+++ b/lib/render/template.ml
@@ -0,0 +1,151 @@
+type value =
+  | Str of string
+  | Bool of bool
+  | List of value list
+  | Obj of (string * value) list
+
+type node =
+  | Text of string
+  | Var of string list
+  | Section of string list * node list
+  | Inverted of string list * node list
+
+type tag = TVar of string list | TOpen of string list | TInv of string list | TClose of string list | TComment
+
+let trim = String.trim
+
+let path s =
+  String.split_on_char '.' (trim s) |> List.map trim |> List.filter (fun x -> x <> "")
+
+(* Lex into a flat list of text and tags. Returns Error on an unterminated tag
+   rather than treating the remainder as text: silently swallowing "{{name" is
+   how a typo becomes invisible missing output. *)
+let lex src =
+  let n = String.length src in
+  let out = ref [] in
+  let buf = Buffer.create 256 in
+  let flush () =
+    if Buffer.length buf > 0 then (out := `Text (Buffer.contents buf) :: !out; Buffer.clear buf)
+  in
+  let rec go i =
+    if i >= n then (flush (); Ok (List.rev !out))
+    else if i + 1 < n && src.[i] = '{' && src.[i + 1] = '{' then
+      match String.index_from_opt src (i + 2) '}' with
+      | Some j when j + 1 < n && src.[j + 1] = '}' ->
+          let body = String.sub src (i + 2) (j - i - 2) in
+          flush ();
+          let tag =
+            let b = trim body in
+            if b = "" then Error "empty tag {{}}"
+            else
+              (* Every sigil form (var, #, ^, /) resolves a dotted path; an
+                 empty path ("{{.}}", "{{#}}", "{{^}}", "{{/}}") names
+                 nothing -- there is no "current context" concept for a bare
+                 dot to mean, so it is a parse error rather than an invented
+                 behaviour Task 3 would have to define. *)
+              let with_path ctor rest =
+                match path rest with
+                | [] -> Error "empty tag path: {{.}} and {{#}} name nothing"
+                | p -> Ok (ctor p)
+              in
+              match b.[0] with
+              | '#' -> with_path (fun p -> TOpen p) (String.sub b 1 (String.length b - 1))
+              | '^' -> with_path (fun p -> TInv p) (String.sub b 1 (String.length b - 1))
+              | '/' -> with_path (fun p -> TClose p) (String.sub b 1 (String.length b - 1))
+              | '!' -> Ok TComment
+              | '>' -> Error "partials are not supported: a template may not include another file"
+              | _ -> with_path (fun p -> TVar p) b
+          in
+          (match tag with
+           | Error e -> Error e
+           | Ok t -> out := `Tag t :: !out; go (j + 2))
+      | _ -> Error "unterminated tag: '{{' with no matching '}}'"
+    else (Buffer.add_char buf src.[i]; go (i + 1))
+  in
+  go 0
+
+(* Fold the flat list into a tree, checking that every close matches its open. *)
+let build items =
+  let rec go acc stack items =
+    match items with
+    | [] -> (
+        match stack with
+        | [] -> Ok (List.rev acc)
+        | (p, _, _) :: _ -> Error ("unclosed section {{#" ^ String.concat "." p ^ "}}"))
+    | `Text "" :: rest -> go acc stack rest
+    | `Text t :: rest -> go (Text t :: acc) stack rest
+    | `Tag TComment :: rest -> go acc stack rest
+    | `Tag (TVar p) :: rest -> go (Var p :: acc) stack rest
+    | `Tag (TOpen p) :: rest -> go [] ((p, `Sec, acc) :: stack) rest
+    | `Tag (TInv p) :: rest -> go [] ((p, `Inv, acc) :: stack) rest
+    | `Tag (TClose p) :: rest -> (
+        match stack with
+        | [] -> Error ("close tag {{/" ^ String.concat "." p ^ "}} with no open section")
+        | (op, kind, outer) :: tl ->
+            if op <> p then
+              Error
+                ("mismatched close: {{#" ^ String.concat "." op ^ "}} closed by {{/"
+               ^ String.concat "." p ^ "}}")
+            else
+              let inner = List.rev acc in
+              let node = match kind with `Sec -> Section (op, inner) | `Inv -> Inverted (op, inner) in
+              go (node :: outer) tl rest)
+  in
+  go [] [] items
+
+let parse src = match lex src with Error e -> Error e | Ok items -> build items
+
+(* Scope is a STACK, innermost first: a section pushes its own object, and a
+   lookup falls back outward. Without the fallback a grid template could not
+   reach the year number from inside a week. *)
+let rec lookup stack path =
+  match stack with
+  | [] -> None
+  | top :: rest -> (
+      match descend top path with Some v -> Some v | None -> lookup rest path)
+
+and descend v path =
+  match (v, path) with
+  | _, [] -> Some v
+  | Obj kvs, k :: tl -> (
+      match List.assoc_opt k kvs with Some v' -> descend v' tl | None -> None)
+  | _ -> None
+
+let truthy = function
+  | Bool b -> b
+  | Str "" -> false
+  | Str _ -> true
+  | List [] -> false
+  | List _ -> true
+  | Obj _ -> true
+
+let render ~flavour nodes value =
+  let b = Buffer.create 4096 in
+  let rec go stack nodes =
+    List.iter
+      (fun node ->
+        match node with
+        | Text t -> Buffer.add_string b t
+        | Var p -> (
+            match lookup stack p with
+            | Some (Str s) -> Buffer.add_string b (Escape.apply flavour s)
+            | Some (Bool true) -> Buffer.add_string b "true"
+            | Some (Bool false) -> ()
+            | Some (List _) | Some (Obj _) | None -> ())
+        | Section (p, body) -> (
+            match lookup stack p with
+            | None -> ()
+            | Some (List items) -> List.iter (fun it -> go (it :: stack) body) items
+            | Some v when truthy v -> go (v :: stack) body
+            | Some _ -> ())
+        | Inverted (p, body) -> (
+            match lookup stack p with
+            | None -> go stack body
+            | Some v -> if not (truthy v) then go stack body))
+      nodes
+  in
+  go [ value ] nodes;
+  Buffer.contents b
+
+let render_string ~flavour src value =
+  match parse src with Error e -> Error e | Ok nodes -> Ok (render ~flavour nodes value)