summaryrefslogtreecommitdiff
path: root/lib/render
diff options
context:
space:
mode:
authorLukasz Kasprzak <lukas@labunix.xyz>2026-08-19 11:48:30 +0200
committerLukasz Kasprzak <lukas@labunix.xyz>2026-08-19 11:48:30 +0200
commit6762ce46af3cb12bc6ae37cda762c5d95add7903 (patch)
treebc1d8c86050d0149ff961a9a4ff838f9c474ac2a /lib/render
parent897c274fd28402159ca6d45eedc1257b1ce98696 (diff)
parent390bc6ac5196a946c473d0dbe7760fa41837c428 (diff)
downloadcolitur-6762ce46af3cb12bc6ae37cda762c5d95add7903.tar.gz
colitur-6762ce46af3cb12bc6ae37cda762c5d95add7903.zip
feat: output, rendering and publishing
Gives colitur a publishable exit. Until now its only output was terminal rows; it can now print an ordo booklet and a wall calendar, publish an iCalendar feed people subscribe to, and serve a static JSON/XML API. lib/render escaping (six flavours + RFC 5545 folding), a deliberately logic-less template engine, the view model, and five emitters (CSV, JSON, XML, iCalendar, S-expression) CLI emit, table, render, publish -- all accepting --overlay templates ordo booklet in six flavours, wall grid in three schema day-v1.json and colitur-v1.xsd, the published contract man colitur-templates.5, plus colitur.1 updates The view model is why the engine can stay logic-less: a month grid needs leading blank cells, week bucketing and an in-month test, and a logic-less template can compute none of it. Shaping the data in OCaml keeps the engine safe for untrusted templates and makes the grid trivial. Formats split by whether correctness is mechanical. Presentation goes through templates; iCalendar and XML get dedicated emitters, because folding, exclusive DTEND, stable UIDs and schema fidelity are rules a template cannot enforce and each fails silently in a subscriber's client rather than loudly at generation. publish is deterministic and non-destructive: two runs produce a byte-identical tree, and --prune removes only files a previous run created, refusing any manifest entry that escapes the output directory. No new dependencies. The kernel and rite modules are untouched, and colitur day and colitur readings remain byte-identical.
Diffstat (limited to 'lib/render')
-rw-r--r--lib/render/dune5
-rw-r--r--lib/render/emit_csv.ml44
-rw-r--r--lib/render/emit_csv.mli9
-rw-r--r--lib/render/emit_ics.ml107
-rw-r--r--lib/render/emit_ics.mli15
-rw-r--r--lib/render/emit_json.ml47
-rw-r--r--lib/render/emit_json.mli10
-rw-r--r--lib/render/emit_xml.ml48
-rw-r--r--lib/render/emit_xml.mli8
-rw-r--r--lib/render/escape.ml95
-rw-r--r--lib/render/escape.mli28
-rw-r--r--lib/render/template.ml151
-rw-r--r--lib/render/template.mli37
-rw-r--r--lib/render/view.ml149
-rw-r--r--lib/render/view.mli24
15 files changed, 777 insertions, 0 deletions
diff --git a/lib/render/dune b/lib/render/dune
new file mode 100644
index 0000000..7880188
--- /dev/null
+++ b/lib/render/dune
@@ -0,0 +1,5 @@
+(library
+ (name colitur_render)
+ (libraries colitur_kernel sexplib)
+ (preprocess
+ (pps ppx_sexp_conv)))
diff --git a/lib/render/emit_csv.ml b/lib/render/emit_csv.ml
new file mode 100644
index 0000000..b478265
--- /dev/null
+++ b/lib/render/emit_csv.ml
@@ -0,0 +1,44 @@
+(* emit_csv.ml *)
+module T = Template
+
+let escape_field s =
+ let needs =
+ String.exists (fun c -> c = ',' || c = '"' || c = '\n' || c = '\r') s
+ in
+ if not needs then s
+ else begin
+ let b = Buffer.create (String.length s + 8) in
+ Buffer.add_char b '"';
+ String.iter (fun c -> if c = '"' then Buffer.add_string b "\"\"" else Buffer.add_char b c) s;
+ Buffer.add_char b '"';
+ Buffer.contents b
+ end
+
+let get v k = match v with T.Obj kvs -> List.assoc_opt k kvs | _ -> None
+let s v k = match get v k with Some (T.Str x) -> x | _ -> ""
+let nested v a b = match get v a with Some inner -> s inner b | None -> ""
+
+let columns =
+ [ "date"; "rite"; "season"; "week"; "slug"; "rank"; "colour"; "subject";
+ "name_la"; "name_en"; "first"; "gospel"; "comms" ]
+
+let row ~rite d =
+ let comms =
+ match get d "comms" with
+ | Some (T.List l) -> String.concat " " (List.map (fun c -> s c "slug") l)
+ | _ -> ""
+ in
+ String.concat ","
+ (List.map escape_field
+ [ s d "iso"; rite; s d "season"; s d "week"; s d "slug"; s d "rank";
+ s d "colour"; s d "subject"; nested d "name" "la"; nested d "name" "en";
+ s d "first"; s d "gospel"; comms ])
+
+let year v =
+ let rite = s v "rite" in
+ let days = match get v "days" with Some (T.List l) -> l | _ -> [] in
+ let b = Buffer.create (64 * 400) in
+ Buffer.add_string b (String.concat "," columns);
+ Buffer.add_char b '\n';
+ List.iter (fun d -> Buffer.add_string b (row ~rite d); Buffer.add_char b '\n') days;
+ Buffer.contents b
diff --git a/lib/render/emit_csv.mli b/lib/render/emit_csv.mli
new file mode 100644
index 0000000..262f660
--- /dev/null
+++ b/lib/render/emit_csv.mli
@@ -0,0 +1,9 @@
+(* emit_csv.mli *)
+(** One row per day, RFC 4180. Consumes the VIEW, not the kernel, so every
+ emitter describes exactly the same fields as every template. *)
+
+(** RFC 4180 section 2: quote a field containing a comma, a quote or a newline;
+ double an embedded quote. Exposed for testing. *)
+val escape_field : string -> string
+
+val year : Template.value -> string
diff --git a/lib/render/emit_ics.ml b/lib/render/emit_ics.ml
new file mode 100644
index 0000000..41efb95
--- /dev/null
+++ b/lib/render/emit_ics.ml
@@ -0,0 +1,107 @@
+(* emit_ics.ml *)
+module T = Template
+
+let get v k = match v with T.Obj kvs -> List.assoc_opt k kvs | _ -> None
+let s v k = match get v k with Some (T.Str x) -> x | _ -> ""
+
+let compact iso = (* "2027-01-13" -> "20270113" *)
+ String.concat "" (String.split_on_char '-' iso)
+
+(* Civil-date successor without touching the kernel: parse, add, re-format via
+ Colitur_kernel.Date, which is already total and validated over 1583..9999. *)
+let next_day iso =
+ match Colitur_kernel.Date.of_iso8601 iso with
+ | Ok d -> Colitur_kernel.Date.to_iso8601 (Colitur_kernel.Date.add_days d 1)
+ (* Dead on shipped data: [event]'s own [iso <> ""] guard is the only
+ caller, and every real [iso] it passes came from [Date.to_iso8601] in
+ the first place, so it always parses. Left total rather than raising
+ (the kernel/render determinism rule), but a caller relying on this
+ branch would silently get DTEND == DTSTART -- a zero-length event --
+ with no diagnostic, if it were ever actually reached. Documented, not
+ fixed: nothing exercises it. *)
+ | Error _ -> iso
+
+(* RFC 5545 section 3.6.1: a VEVENT with a DATE-valued DTSTART and NEITHER
+ DTEND NOR DURATION has an implicit duration of exactly one day, so
+ omitting DTEND for the domain's own last day is the standard's own
+ correct way to say precisely what we mean -- not a workaround.
+
+ Needed because [Date.add_days] is itself UNBOUNDED (date.mli: "may
+ denote a year outside 1583..9999 -- only [make] enforces the domain"):
+ the successor of 9999-12-31 is a real [Date.t] that [next_day] above
+ happily renders as "10000-01-01" (date.ml's [to_iso8601] pads with
+ [Printf.sprintf "%04d-..."] but never truncates), which [compact] would
+ turn into a 9-digit, non-conformant DATE. [Date.make] is the ONE kernel
+ function that actually enforces 1583..9999 (date.mli), so this takes
+ [next_day]'s own successor string, re-derives its year/month/day, and
+ re-validates THOSE through [make] before trusting the string at all.
+ [None] means "one day past the domain's own last day"; the caller omits
+ DTEND entirely rather than clamp, truncate, or fall back to DURATION. *)
+let dtend_of iso =
+ let next = next_day iso in
+ match String.split_on_char '-' next with
+ | [ y; m; d ] -> (
+ match (int_of_string_opt y, int_of_string_opt m, int_of_string_opt d) with
+ | Some year, Some month, Some day -> (
+ match Colitur_kernel.Date.make ~year ~month ~day with
+ | Ok _ -> Some next
+ | Error _ -> None)
+ | _ -> None)
+ | _ -> None
+
+let esc x = Escape.apply Escape.Ics x
+let line b l = Buffer.add_string b (Escape.fold_ics l)
+
+let event b ~rite ~dtstamp d =
+ let iso = s d "iso" in
+ if iso <> "" then begin
+ let name =
+ match get d "name" with
+ | Some (T.Obj kvs) -> (
+ match List.assoc_opt "en" kvs with
+ | Some (T.Str x) when x <> "" -> x
+ | _ -> ( match List.assoc_opt "la" kvs with Some (T.Str x) -> x | _ -> s d "slug"))
+ | _ -> s d "slug"
+ in
+ let summary = Printf.sprintf "%s (%s, %s)" name (s d "rank") (s d "colour") in
+ let desc =
+ String.concat "\n"
+ (List.filter (fun x -> x <> "")
+ [ (if s d "first" <> "" then "Epistle " ^ s d "first" else "");
+ (if s d "gospel" <> "" then "Gospel " ^ s d "gospel" else "") ])
+ in
+ line b "BEGIN:VEVENT";
+ (* RFC 5545 section 3.8.4.7: the UID must be stable across regenerations,
+ or every subscriber gets a duplicate of the whole year. *)
+ line b (Printf.sprintf "UID:%s-%s@colitur" (compact iso) rite);
+ line b ("DTSTAMP:" ^ dtstamp);
+ line b ("DTSTART;VALUE=DATE:" ^ compact iso);
+ (* RFC 5545 section 3.6.1: DTEND is EXCLUSIVE for an all-day event -- and
+ omitted entirely, rather than emitted malformed, for the one event
+ whose successor falls outside the engine's own 1583..9999 domain
+ (see [dtend_of] above). *)
+ (match dtend_of iso with
+ | Some next -> line b ("DTEND;VALUE=DATE:" ^ compact next)
+ | None -> ());
+ line b ("SUMMARY:" ^ esc summary);
+ if desc <> "" then line b ("DESCRIPTION:" ^ esc desc);
+ line b "TRANSP:TRANSPARENT";
+ line b "END:VEVENT"
+ end
+
+let year ?dtstamp ?calname v =
+ let rite = s v "rite" in
+ let y = s v "year" in
+ let dtstamp = match dtstamp with Some x -> x | None -> y ^ "0101T000000Z" in
+ let calname = match calname with Some x -> x | None -> "colitur " ^ rite ^ " " ^ y in
+ let b = Buffer.create (256 * 1024) in
+ line b "BEGIN:VCALENDAR";
+ line b "VERSION:2.0";
+ line b "PRODID:-//colitur//liturgical calendar//EN";
+ line b "CALSCALE:GREGORIAN";
+ line b "METHOD:PUBLISH";
+ (* Non-standard but universally honoured; without it clients show the URL. *)
+ line b ("X-WR-CALNAME:" ^ esc calname);
+ (match get v "days" with Some (T.List l) -> List.iter (event b ~rite ~dtstamp) l | _ -> ());
+ line b "END:VCALENDAR";
+ Buffer.contents b
diff --git a/lib/render/emit_ics.mli b/lib/render/emit_ics.mli
new file mode 100644
index 0000000..270bd76
--- /dev/null
+++ b/lib/render/emit_ics.mli
@@ -0,0 +1,15 @@
+(* emit_ics.mli *)
+(** RFC 5545 iCalendar. NOT a template job: folding, escaping, exclusive DTEND
+ and stable UIDs are rules a logic-less template cannot enforce, and getting
+ any of them wrong produces a feed that fails silently in a subscriber's
+ client (spec section 6). *)
+
+(** [year ?dtstamp ?calname view].
+
+ [dtstamp] defaults to [YYYY0101T000000Z] for the view's own year. It is a
+ PARAMETER, never a clock read: RFC 5545 requires DTSTAMP, the obvious
+ implementation reads the wall clock, and that would both violate the
+ kernel's determinism rule and make two feeds from identical data differ
+ byte-for-byte -- defeating reproducible builds and a reviewable git diff on
+ a published tree. Same data in, same bytes out. *)
+val year : ?dtstamp:string -> ?calname:string -> Template.value -> string
diff --git a/lib/render/emit_json.ml b/lib/render/emit_json.ml
new file mode 100644
index 0000000..272e4ca
--- /dev/null
+++ b/lib/render/emit_json.ml
@@ -0,0 +1,47 @@
+(* emit_json.ml *)
+module T = Template
+
+let escape_string s =
+ let b = Buffer.create (String.length s + 8) in
+ Buffer.add_char b '"';
+ String.iter
+ (fun c ->
+ match c with
+ | '"' -> Buffer.add_string b "\\\""
+ | '\\' -> Buffer.add_string b "\\\\"
+ | '\n' -> Buffer.add_string b "\\n"
+ | '\r' -> Buffer.add_string b "\\r"
+ | '\t' -> Buffer.add_string b "\\t"
+ | c when Char.code c < 0x20 -> Buffer.add_string b (Printf.sprintf "\\u%04x" (Char.code c))
+ | c -> Buffer.add_char b c)
+ s;
+ Buffer.add_char b '"';
+ Buffer.contents b
+
+(* Emit the view tree directly. Bools stay bools; everything else is a string,
+ an array or an object -- there are no numbers in the view, deliberately, so a
+ consumer never has to guess whether "week" is 2 or "2". *)
+let rec write b (v : T.value) =
+ match v with
+ | T.Str s -> Buffer.add_string b (escape_string s)
+ | T.Bool x -> Buffer.add_string b (if x then "true" else "false")
+ | T.List l ->
+ Buffer.add_char b '[';
+ List.iteri (fun i x -> if i > 0 then Buffer.add_char b ','; write b x) l;
+ Buffer.add_char b ']'
+ | T.Obj kvs ->
+ Buffer.add_char b '{';
+ List.iteri
+ (fun i (k, x) ->
+ if i > 0 then Buffer.add_char b ',';
+ Buffer.add_string b (escape_string k);
+ Buffer.add_char b ':';
+ write b x)
+ kvs;
+ Buffer.add_char b '}'
+
+let year v =
+ let b = Buffer.create (64 * 1024) in
+ write b v;
+ Buffer.add_char b '\n';
+ Buffer.contents b
diff --git a/lib/render/emit_json.mli b/lib/render/emit_json.mli
new file mode 100644
index 0000000..91c8f48
--- /dev/null
+++ b/lib/render/emit_json.mli
@@ -0,0 +1,10 @@
+(* emit_json.mli *)
+(** JSON writer. Hand-rolled: the dependency list is frozen (spec section 1),
+ and writing JSON is a page of code where escaping is the only subtlety.
+ Output shape is pinned by schema/day-v1.json, the published contract. *)
+
+(** RFC 8259 section 7, including \u-escaping of control characters below 0x20.
+ Returns the value WITH its surrounding quotes. Exposed for testing. *)
+val escape_string : string -> string
+
+val year : Template.value -> string
diff --git a/lib/render/emit_xml.ml b/lib/render/emit_xml.ml
new file mode 100644
index 0000000..4e4b51a
--- /dev/null
+++ b/lib/render/emit_xml.ml
@@ -0,0 +1,48 @@
+(* emit_xml.ml *)
+module T = Template
+
+let escape s = Escape.apply Escape.Xml s
+
+let get v k = match v with T.Obj kvs -> List.assoc_opt k kvs | _ -> None
+let s v k = match get v k with Some (T.Str x) -> x | _ -> ""
+let el b name value =
+ Buffer.add_string b (" <" ^ name ^ ">" ^ escape value ^ "</" ^ name ^ ">\n")
+
+let day b d =
+ Buffer.add_string b (" <day date=\"" ^ escape (s d "iso") ^ "\">\n");
+ el b "season" (s d "season");
+ el b "week" (s d "week");
+ el b "slug" (s d "slug");
+ el b "rank" (s d "rank");
+ el b "colour" (s d "colour");
+ el b "subject" (s d "subject");
+ (match get d "name" with
+ | Some (T.Obj kvs) ->
+ List.iter
+ (fun (lang, v) ->
+ match v with
+ | T.Str x -> Buffer.add_string b (" <name lang=\"" ^ escape lang ^ "\">" ^ escape x ^ "</name>\n")
+ | _ -> ())
+ kvs
+ | _ -> ());
+ (match get d "comms" with
+ | Some (T.List l) ->
+ List.iter (fun c -> Buffer.add_string b (" <commemoration>" ^ escape (s c "slug") ^ "</commemoration>\n")) l
+ | _ -> ());
+ let cite name value =
+ if value <> "" then
+ Buffer.add_string b (" <citation part=\"" ^ name ^ "\">" ^ escape value ^ "</citation>\n")
+ in
+ cite "first" (s d "first");
+ cite "gospel" (s d "gospel");
+ Buffer.add_string b " </day>\n"
+
+let year v =
+ let b = Buffer.create (128 * 1024) in
+ Buffer.add_string b "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n";
+ Buffer.add_string b
+ ("<calendar rite=\"" ^ escape (s v "rite") ^ "\" year=\"" ^ escape (s v "year") ^ "\">\n");
+ Buffer.add_string b " <days>\n";
+ (match get v "days" with Some (T.List l) -> List.iter (day b) l | _ -> ());
+ Buffer.add_string b " </days>\n</calendar>\n";
+ Buffer.contents b
diff --git a/lib/render/emit_xml.mli b/lib/render/emit_xml.mli
new file mode 100644
index 0000000..4d539d6
--- /dev/null
+++ b/lib/render/emit_xml.mli
@@ -0,0 +1,8 @@
+(* emit_xml.mli *)
+(** Element-per-field XML. Attributes carry identity only (rite, year, date);
+ everything else is an element, and there is no mixed content -- so a
+ consumer's XPath never has to distinguish the two. Shape pinned by
+ schema/colitur-v1.xsd. *)
+
+val escape : string -> string
+val year : Template.value -> string
diff --git a/lib/render/escape.ml b/lib/render/escape.ml
new file mode 100644
index 0000000..f506c44
--- /dev/null
+++ b/lib/render/escape.ml
@@ -0,0 +1,95 @@
+type flavour = Latex | Groff | Html | Xml | Ics | None_
+
+let all = [ Latex; Groff; Html; Xml; Ics; None_ ]
+
+let to_string = function
+ | Latex -> "latex" | Groff -> "groff" | Html -> "html"
+ | Xml -> "xml" | Ics -> "ics" | None_ -> "none"
+
+let of_string = function
+ | "latex" -> Some Latex | "groff" -> Some Groff | "html" -> Some Html
+ | "xml" -> Some Xml | "ics" -> Some Ics | "none" -> Some None_
+ | _ -> None
+
+let of_extension = function
+ | ".tex" -> Some Latex
+ | ".ms" | ".mom" | ".me" -> Some Groff
+ | ".html" | ".htm" -> Some Html
+ | ".xml" -> Some Xml
+ | ".ics" -> Some Ics
+ | ".md" | ".adoc" | ".txt" -> Some None_
+ | _ -> None
+
+(* Replace each character with its expansion, in ONE pass. A sequence of
+ String.concat replacements would double-escape: "&" -> "\\&" then the
+ backslash rule would rewrite the backslash it just introduced. *)
+let expand f s =
+ let b = Buffer.create (String.length s + 16) in
+ String.iter (fun c -> Buffer.add_string b (f c)) s;
+ Buffer.contents b
+
+let latex = function
+ | '\\' -> "\\textbackslash{}"
+ | '{' -> "\\{" | '}' -> "\\}"
+ | '$' -> "\\$" | '&' -> "\\&" | '#' -> "\\#"
+ | '_' -> "\\_" | '%' -> "\\%"
+ | '^' -> "\\textasciicircum{}"
+ | '~' -> "\\textasciitilde{}"
+ | c -> String.make 1 c
+
+let html = function
+ | '&' -> "&amp;" | '<' -> "&lt;" | '>' -> "&gt;"
+ | '"' -> "&quot;" | '\'' -> "&#39;"
+ | c -> String.make 1 c
+
+let ics = function
+ | '\\' -> "\\\\" | ';' -> "\\;" | ',' -> "\\,"
+ | '\n' -> "\\n" | '\r' -> ""
+ | c -> String.make 1 c
+
+(* groff: a backslash starts an escape, and a '.' or '\'' in COLUMN ONE starts a
+ request. \& is the zero-width non-printing character that defuses it. *)
+let groff s =
+ let escaped = expand (function '\\' -> "\\e" | c -> String.make 1 c) s in
+ if String.length escaped > 0 && (escaped.[0] = '.' || escaped.[0] = '\'') then "\\&" ^ escaped
+ else escaped
+
+let apply flavour s =
+ match flavour with
+ | Latex -> expand latex s
+ | Groff -> groff s
+ | Html | Xml -> expand html s
+ | Ics -> expand ics s
+ | None_ -> s
+
+(* RFC 5545 section 3.1. A continuation byte is 0x80-0xBF; backing off to a
+ non-continuation byte keeps every fold on a character boundary. *)
+let fold_ics line =
+ let n = String.length line in
+ let b = Buffer.create (n + (n / 70) + 8) in
+ let is_cont c = Char.code c land 0xC0 = 0x80 in
+ let rec go pos first =
+ let limit = if first then 75 else 74 (* the leading space costs one octet *) in
+ if n - pos <= limit then (
+ if not first then Buffer.add_char b ' ';
+ Buffer.add_string b (String.sub line pos (n - pos));
+ Buffer.add_string b "\r\n")
+ else begin
+ let cut = ref (pos + limit) in
+ while !cut > pos && is_cont line.[!cut] do decr cut done;
+ (* Valid UTF-8's longest continuation run is 3, so backoff finds a
+ boundary within a few bytes. But this function must stay TOTAL on
+ ARBITRARY octet strings, not only valid UTF-8: 74+ consecutive
+ continuation bytes back `cut` all the way down to `pos`, which would
+ yield a zero-length chunk and recurse on the identical position
+ forever. When backoff finds no boundary inside the window, cut hard
+ at the limit instead -- forward progress is then unconditional. *)
+ if !cut = pos then cut := pos + limit;
+ if not first then Buffer.add_char b ' ';
+ Buffer.add_string b (String.sub line pos (!cut - pos));
+ Buffer.add_string b "\r\n";
+ go !cut false
+ end
+ in
+ go 0 true;
+ Buffer.contents b
diff --git a/lib/render/escape.mli b/lib/render/escape.mli
new file mode 100644
index 0000000..97cf050
--- /dev/null
+++ b/lib/render/escape.mli
@@ -0,0 +1,28 @@
+(** Per-flavour escaping for the template engine, plus RFC 5545 line folding.
+
+ Knows nothing about calendars. Pure and total: every function is defined on
+ every string, and none reads the clock, the environment or the filesystem. *)
+
+(** The six escaping modes. Markdown, AsciiDoc and plain text all use [None_]:
+ their metacharacter sets are context-dependent, and escaping them
+ aggressively produces worse output than not escaping at all (spec section 5).
+ This is a documented limitation of those flavours. *)
+type flavour = Latex | Groff | Html | Xml | Ics | None_
+
+val all : flavour list
+val to_string : flavour -> string
+val of_string : string -> flavour option
+
+(** [of_extension ".tex"] is [Some Latex]. Returns [None] for an unrecognised
+ extension: the caller must treat that as an error, never as a fallback to
+ [None_] (spec section 5 -- guessing wrong here produces malformed output
+ that looks fine until it does not). *)
+val of_extension : string -> flavour option
+
+(** Escape one interpolated value for [flavour]. *)
+val apply : flavour -> string -> string
+
+(** Fold one unfolded content line per RFC 5545 section 3.1: at most 75 octets
+ per line, continuation lines prefixed with one space, CRLF terminators,
+ never splitting a UTF-8 sequence. The returned string ends with CRLF. *)
+val fold_ics : string -> string
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)
diff --git a/lib/render/template.mli b/lib/render/template.mli
new file mode 100644
index 0000000..4118496
--- /dev/null
+++ b/lib/render/template.mli
@@ -0,0 +1,37 @@
+(** A deliberately logic-less template engine (spec section 5).
+
+ A template is DATA, never a program: placeholders, sections, inverted
+ sections and comments, and nothing else. There are no partials, no lambdas,
+ no expression evaluation, no arithmetic, and no filesystem or process
+ access. There is deliberately no "raw" or triple-brace form -- a template
+ cannot opt out of its flavour's escaping.
+
+ Anything a calendar needs that this cannot express (a month grid's leading
+ blanks, week bucketing) is computed in {!View} and handed in as data. That
+ division is the design, not a workaround. *)
+
+(** What a template can be rendered against. *)
+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 (** dotted path, e.g. ["name"; "la"] *)
+ | Section of string list * node list
+ | Inverted of string list * node list
+
+(** Never raises; a malformed template is an [Error] with a human-readable
+ reason, because the template is user input. *)
+val parse : string -> (node list, string) result
+
+(** Render against a value. Escaping is applied to every interpolated value and
+ NEVER to the template's own literal text, which is the author's markup.
+ A missing key renders as the empty string -- the one deliberate silence, so
+ that a template survives a rite that does not set every optional field. *)
+val render : flavour:Escape.flavour -> node list -> value -> string
+
+(** [parse] then [render]. *)
+val render_string : flavour:Escape.flavour -> string -> value -> (string, string) result
diff --git a/lib/render/view.ml b/lib/render/view.ml
new file mode 100644
index 0000000..733aa45
--- /dev/null
+++ b/lib/render/view.ml
@@ -0,0 +1,149 @@
+module K = Colitur_kernel
+module T = Template
+
+let str s = T.Str s
+let bool b = T.Bool b
+
+let month_names =
+ [| ("Ianuarius", "January"); ("Februarius", "February"); ("Martius", "March");
+ ("Aprilis", "April"); ("Maius", "May"); ("Iunius", "June");
+ ("Iulius", "July"); ("Augustus", "August"); ("September", "September");
+ ("October", "October"); ("November", "November"); ("December", "December") |]
+
+let names_value (n : K.Names.t) =
+ T.Obj (List.map (fun (l, s) -> (K.Lang.to_string l, str s)) (K.Names.to_list n))
+
+let dow_int = function
+ | K.Date.Sun -> 0 | K.Date.Mon -> 1 | K.Date.Tue -> 2 | K.Date.Wed -> 3
+ | K.Date.Thu -> 4 | K.Date.Fri -> 5 | K.Date.Sat -> 6
+
+let citation_ref cits part =
+ match
+ List.find_opt (fun (c : K.Citation.t) -> c.K.Citation.part = part) cits
+ with
+ | Some c -> c.K.Citation.reference
+ | None -> ""
+
+let comm_value (c, priv) =
+ T.Obj
+ [ ("slug", str (K.Slug.to_string c.K.Celebration.slug));
+ ("name", names_value c.K.Celebration.names);
+ ("privileged", bool (priv = K.Precedence.Privileged)) ]
+
+(* A padding cell: present so a grid row always has seven entries, and flagged
+ so a template can render it blank. Every field a real day has is present and
+ empty, so a template never hits a missing key on a padding cell. *)
+let padding_cell dow =
+ T.Obj
+ [ ("iso", str ""); ("dom", str ""); ("dow", str (string_of_int dow));
+ ("in_month", bool false);
+ ("season", str ""); ("week", str ""); ("slug", str "");
+ ("name", T.Obj []); ("rank", str "");
+ ("colour", str "");
+ ("is_white", bool false); ("is_red", bool false); ("is_green", bool false);
+ ("is_violet", bool false); ("is_rose", bool false); ("is_black", bool false);
+ ("subject", str ""); ("comms", T.List []);
+ ("transferred_in", T.List []); ("transferred_out", T.List []);
+ ("first", str ""); ("gospel", str ""); ("last", bool false) ]
+
+let day_value ~vocab (d : ('s, 'r) K.Liturgical_day.t) =
+ let date = d.K.Liturgical_day.date in
+ let tmp = d.K.Liturgical_day.temporal in
+ let cel = d.K.Liturgical_day.observed in
+ let colour = cel.K.Celebration.colour in
+ let is c = bool (colour = c) in
+ T.Obj
+ [ ("iso", str (K.Date.to_iso8601 date));
+ ("dom", str (string_of_int (K.Date.day date)));
+ ("dow", str (string_of_int (dow_int (K.Date.weekday date))));
+ ("in_month", bool true);
+ ("season", str (vocab.K.Vocab.season_to_string tmp.K.Temporal.season));
+ ("week", str (match tmp.K.Temporal.week with Some w -> string_of_int w | None -> ""));
+ ("slug", str (K.Slug.to_string cel.K.Celebration.slug));
+ ("name", names_value cel.K.Celebration.names);
+ (* [rank] is the kernel's own class string ("class-1"); there is
+ deliberately no separate localized rank label here -- the kernel
+ has no per-language rank names to draw one from, and a field
+ whose contents cannot honestly differ from [name] should not
+ exist just to exist. Do not re-add one until the kernel can. *)
+ ("rank", str (vocab.K.Vocab.rank_to_string cel.K.Celebration.rank));
+ ("colour", str (K.Colour.to_string colour));
+ ("is_white", is K.Colour.White); ("is_red", is K.Colour.Red);
+ ("is_green", is K.Colour.Green); ("is_violet", is K.Colour.Violet);
+ ("is_rose", is K.Colour.Rose); ("is_black", is K.Colour.Black);
+ ("subject", str (K.Subject.to_string cel.K.Celebration.subject));
+ ("comms", T.List (List.map comm_value d.K.Liturgical_day.commemorations));
+ ( "transferred_in",
+ T.List
+ (match d.K.Liturgical_day.transferred_in with
+ | None -> []
+ | Some c -> [ T.Obj [ ("slug", str (K.Slug.to_string c.K.Celebration.slug)) ] ]) );
+ ( "transferred_out",
+ T.List
+ (List.map
+ (fun (c, dest) ->
+ T.Obj
+ [ ("slug", str (K.Slug.to_string c.K.Celebration.slug));
+ ("to", str (K.Date.to_iso8601 dest)) ])
+ d.K.Liturgical_day.transferred_out) );
+ ("first", str (citation_ref d.K.Liturgical_day.citations K.Citation.First));
+ ("gospel", str (citation_ref d.K.Liturgical_day.citations K.Citation.Gospel));
+ (* overwritten per grid row by [set_last]; false in the flat [days] list *)
+ ("last", bool false) ]
+
+(* Bucket a month's day values into Sunday-started weeks of exactly seven cells,
+ padding both ends. This is the computation the template cannot do. *)
+(* [last] is true on the seventh cell of a row. A table row needs its separator
+ BETWEEN cells and the engine has no "unless last" construct, so the flag is
+ data -- the same rule as [in_month]. Without it the LaTeX grid emits eight
+ columns for seven cells and pdflatex rejects the file. *)
+let set_last cells =
+ List.mapi
+ (fun i c -> match c with T.Obj kvs -> T.Obj (("last", bool (i = 6)) :: List.remove_assoc "last" kvs) | v -> v)
+ cells
+
+let weeks_of_month ~first_dow day_values =
+ let lead = List.init first_dow (fun i -> padding_cell i) in
+ let cells = lead @ day_values in
+ let rec chunk acc = function
+ | [] -> List.rev acc
+ | rest ->
+ let take = min 7 (List.length rest) in
+ let week = List.filteri (fun i _ -> i < take) rest in
+ let tl = List.filteri (fun i _ -> i >= take) rest in
+ let week =
+ if take = 7 then week
+ else week @ List.init (7 - take) (fun i -> padding_cell (take + i))
+ in
+ chunk (week :: acc) tl
+ in
+ List.mapi
+ (fun i w -> T.Obj [ ("num", str (string_of_int (i + 1))); ("days", T.List (set_last w)) ])
+ (chunk [] cells)
+
+let of_days ~vocab ~rite ~year days =
+ let dvs = List.map (fun d -> (d, day_value ~vocab d)) days in
+ let months =
+ List.init 12 (fun i ->
+ let m = i + 1 in
+ let own =
+ List.filter (fun (d, _) -> K.Date.month d.K.Liturgical_day.date = m) dvs
+ in
+ let day_values = List.map snd own in
+ let first_dow =
+ match own with
+ | (d, _) :: _ -> dow_int (K.Date.weekday d.K.Liturgical_day.date)
+ | [] -> 0
+ in
+ let la, en = month_names.(i) in
+ T.Obj
+ [ ("num", str (string_of_int m));
+ ("name", T.Obj [ ("la", str la); ("en", str en) ]);
+ ("days", T.List day_values);
+ ("weeks", T.List (weeks_of_month ~first_dow day_values)) ])
+ in
+ T.Obj
+ [ ("rite", str rite);
+ ("year", str (string_of_int year));
+ ("months", T.List months);
+ ("days", T.List (List.map snd dvs)) ]
diff --git a/lib/render/view.mli b/lib/render/view.mli
new file mode 100644
index 0000000..fb48590
--- /dev/null
+++ b/lib/render/view.mli
@@ -0,0 +1,24 @@
+(** Shapes a civil year of resolved days into the value a template renders
+ against (spec section 4).
+
+ This layer exists because a month grid needs leading blank cells, week
+ bucketing and an "is this cell in the current month" test, and a logic-less
+ template can compute none of it. Shaping the data here keeps the engine
+ logic-less AND makes the grid template trivial. The view model IS the design.
+
+ Both [weeks] and [days] are offered at every level: the booklet walks
+ [days], the grid walks [weeks]. One model, two artefacts, no second code
+ path that could drift.
+
+ Colours are exposed as six booleans rather than a hex string: hex would bake
+ a presentation policy into the engine, and LaTeX, groff and HTML each want a
+ different colour expression. Exactly one of the six is true on every day. *)
+
+val of_days :
+ vocab:('s, 'r) Colitur_kernel.Vocab.t ->
+ rite:string ->
+ year:int ->
+ ('s, 'r) Colitur_kernel.Liturgical_day.t list ->
+ Template.value
+(** [of_days ~vocab ~rite ~year days] where [days] is one civil year, 1 January
+ to 31 December, in order. Pure and total. *)