summaryrefslogtreecommitdiff
path: root/lib/render
diff options
context:
space:
mode:
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. *)
generated by cgit v1.3 (git 2.53.0) at 2026-09-19 20:07:25 +0000