1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
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)
|
