path: root/lib/render/view.ml

module K = Colitur_kernel
module T = Template
module Lang = Colitur_naming.Lang
module Sigla = Colitur_citation.Sigla

let str s = T.Str s
let bool b = T.Bool b

(* Roman numerals for the ordo booklet's own week header ("Hebdomada I" in
   place of the arabic "Hebdomada 1"): a subtractive-form table, most
   significant symbol first, greedily consumed -- the standard algorithm,
   correct for any n >= 1 even though a month's own week count never
   exceeds six (RG carries no numeral convention of its own to cite here;
   this is general vocabulary, the same call [month]/[weekday] already
   made). [num] (arabic) stays alongside it in the view -- see
   [weeks_of_month] below -- so a tradition wanting arabic numbering keeps
   that option without an engine change. *)
let roman_numeral n =
  let table =
    [ (1000, "M"); (900, "CM"); (500, "D"); (400, "CD"); (100, "C"); (90, "XC");
      (50, "L"); (40, "XL"); (10, "X"); (9, "IX"); (5, "V"); (4, "IV"); (1, "I") ]
  in
  let buf = Buffer.create 8 in
  let rec go n = function
    | [] -> ()
    | (v, s) :: rest -> if n >= v then begin Buffer.add_string buf s; go (n - v) ((v, s) :: rest) end else go n rest
  in
  go n table;
  Buffer.contents buf

(* Read a field back off a cell this same module just built ([day_value] or
   [padding_cell]), for [weeks_of_month]'s own first/last-in-month-day
   computation below. Not a general accessor -- it only needs to survive the
   two shapes this file emits. *)
let field_str key = function
  | T.Obj kvs -> ( match List.assoc_opt key kvs with Some (T.Str s) -> s | _ -> "")
  | _ -> ""

let field_bool key = function
  | T.Obj kvs -> ( match List.assoc_opt key kvs with Some (T.Bool b) -> b | _ -> false)
  | _ -> false

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

(* [sigla] renders the stored reference in the caller's chosen style
   (Task 9) -- under [Sigla.verbatim] this is the identity, so [--raw]'s
   own byte-exact contract is unaffected. *)
let citation_ref ~sigla cits part =
  match
    List.find_opt (fun (c : K.Citation.t) -> c.K.Citation.part = part) cits
  with
  | Some c -> Sigla.format sigla c.K.Citation.reference
  | None -> ""

(* A commemoration's own name resolves through the SAME [lang.celebration]
   table as the observed day's -- a commemoration's slug is drawn from the
   identical sanctoral/temporal pool, not a second vocabulary. Templates
   (the ordo booklet, Task 8) interpolate this as a plain [{{name}}] inside
   [{{#comms}}], so it must be a string here too, not the kernel's own
   lang-keyed [Celebration.names] object -- the same reasoning [day_value]'s
   own [name] follows below, applied consistently rather than left as a
   second, differently-shaped name field a template author would have to
   remember. *)
let comm_value ~lang (c, priv) =
  let slug_s = K.Slug.to_string c.K.Celebration.slug in
  T.Obj
    [ ("slug", str slug_s);
      ("name", str (Lang.celebration lang slug_s));
      ("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 -- the same
   key SET as [day_value], not merely the same shape by coincidence. *)
let padding_cell dow =
  T.Obj
    [ ("iso", str ""); ("dom", str ""); ("dow", str (string_of_int dow));
      ("in_month", bool false);
      ("season", str ""); ("season_name", str "");
      ("week", str ""); ("slug", str "");
      ("name", str ""); ("weekday", str "");
      ("rank", str ""); ("rank_name", str "");
      ("colour", str ""); ("colour_name", 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 ~lang ~sigla ~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
  let slug_s = K.Slug.to_string cel.K.Celebration.slug in
  let rank_s = vocab.K.Vocab.rank_to_string cel.K.Celebration.rank in
  let colour_s = K.Colour.to_string colour in
  let season_s = vocab.K.Vocab.season_to_string tmp.K.Temporal.season 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 season_s);
      ("season_name", str (Lang.season lang season_s));
      ("week", str (match tmp.K.Temporal.week with Some w -> string_of_int w | None -> ""));
      ("slug", str slug_s);
      (* The resolved display name. A plain string, not a lang-keyed object:
         a dotted {{name.la}} used to fall back WHOLESALE to the enclosing
         month's own name.la and print "Ianuarius" on unnamed days. One
         string removes that hazard entirely -- there is no dotted path left
         for a partial match to climb out of. Under [Lang.raw] this equals
         [slug] exactly (every lookup in the identity table echoes its key),
         which is what makes [--raw] output byte-stable. *)
      ("name", str (Lang.celebration lang slug_s));
      ("weekday", str (Lang.weekday lang (dow_int (K.Date.weekday date))));
      ("rank", str rank_s);
      ("rank_name", str (Lang.rank lang rank_s));
      ("colour", str colour_s);
      ("colour_name", str (Lang.colour lang colour_s));
      ("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 ~lang) 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 ~sigla d.K.Liturgical_day.citations K.Citation.First));
      ("gospel", str (citation_ref ~sigla 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

(* [month_num]/[month_name]/[month_abbr] are carried onto every WEEK object
   because the engine has no {{../}} parent-path syntax: a nested {{num}}
   inside a week silently finds the WEEK's own number, never the month's,
   so a template that needs the month (the ordo booklet, whose weeks span a
   {{#months}}{{#weeks}} nesting) has no other way to reach it. Shaping the
   data here, rather than inventing template syntax, is the same call the
   [last] flag above already made.

   Weeks are built per-month, one call to this function per month, with
   [day_values] already filtered to that month alone by the caller
   ([of_days] below) -- so a week's in-month days can never cross a month
   boundary; the padding this function adds at both ends is the only thing
   that ever fills a cell with no [dom] of its own. *)
let weeks_of_month ~first_dow ~month_num ~month_name ~month_abbr 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 ->
      (* The week's own in-month days only, in date order (padding cells
         carry [in_month = false] and are excluded) -- always non-empty:
         padding only ever occupies the LEAD of a month's first week or the
         TAIL of its last, never a whole week, since every month has more
         real days than a single week can hold. *)
      let in_month_doms =
        List.filter_map
          (fun c -> if field_bool "in_month" c then Some (int_of_string (field_str "dom" c)) else None)
          w
      in
      let first_dom = match in_month_doms with d :: _ -> d | [] -> 0 in
      let last_dom = match List.rev in_month_doms with d :: _ -> d | [] -> 0 in
      T.Obj
        [ ("num", str (string_of_int (i + 1)));
          (* The week number as a Roman numeral -- a presentation choice a
             template opts into; [num] (arabic) stays alongside it so a
             tradition wanting arabic keeps that without an engine change. *)
          ("num_roman", str (roman_numeral (i + 1)));
          ("month_num", str month_num);
          ("month_name", str month_name);
          ("month_abbr", str month_abbr);
          ("first_dom", str (string_of_int first_dom));
          ("last_dom", str (string_of_int last_dom));
          (* True when the week holds exactly one in-month day -- the flag a
             template needs to choose "Ian 1" over "Ian 1-2" (an en dash plus
             [last_dom] only inside {{^single_day}}). The engine is
             logic-less and cannot compare [first_dom] to [last_dom] itself,
             so the decision is shaped here as data, the same "cheap flag
             beats invented template logic" call [last]/[first] above
             already made -- and deliberately NOT a preformatted span
             string, which would bake a punctuation choice into the engine a
             template or language could no longer change. *)
          ("single_day", bool (List.length in_month_doms = 1));
          (* True on the month's own first week -- Defect 2 (the continuous
             ordo booklet): with the per-week page break gone, a template
             needs SOME signal to print a stronger, standalone month banner
             at the point a new month begins, rather than repeating the
             (unremarkable) "Month . Week N" header run-on run-on. The same
             "cheap flag beats invented template logic" call [last] above
             already made -- there is still no {{../}} parent-path syntax
             to test "is this month's first week" any other way. *)
          ("first", bool (i = 0));
          ("days", T.List (set_last w)) ])
    (chunk [] cells)

(* The [term] vocabulary a template routes every fixed string through
   ({{term.epistle}}, {{term.week}}, ...) so a translated booklet needs no
   template edit. The key list is the vocabulary's own fixed, closed set
   (lang/*.ini's own [term] section, Task 1/3) -- not open like [celebration],
   so it is named here rather than invented a second time from a wildcard
   enumeration. *)
let term_keys = [ "ordo"; "contents"; "epistle"; "lesson"; "gospel"; "commemoration"; "week" ]

let term_value lang = T.Obj (List.map (fun k -> (k, str (Lang.term lang k))) term_keys)

(* A localised grid header row: {name; last} objects, not bare strings --
   the engine rejects an empty tag path ({{.}}) as a parse error, so a
   template walking this list needs a named field to interpolate. Always
   Sunday-first (index 0), matching [padding_cell]'s own [dow] numbering and
   every week this view builds. *)
let weekday_headings lang =
  T.List
    (List.init 7 (fun i -> T.Obj [ ("name", str (Lang.weekday lang i)); ("last", bool (i = 6)) ]))

let of_days ~lang ~sigla ~vocab ~rite ~year days =
  let dvs = List.map (fun d -> (d, day_value ~lang ~sigla ~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 month_num = string_of_int m in
        let month_name = Lang.month lang m in
        let month_abbr = Lang.month_abbr lang m in
        T.Obj
          [ ("num", str month_num);
            ("name", str month_name);
            ("days", T.List day_values);
            ("weeks", T.List (weeks_of_month ~first_dow ~month_num ~month_name ~month_abbr day_values)) ])
  in
  T.Obj
    [ ("rite", str rite);
      (* The reader-facing display name (lang/*.ini's own [rite] section,
         Defect 1) -- [rite] itself stays the stable internal key, exactly
         as [slug] is kept beside [name] on a day/commemoration. Every
         template that used to print the bare id ("ef") now prints this
         field instead. *)
      ("rite_name", str (Lang.rite lang rite));
      ("year", str (string_of_int year));
      ("term", term_value lang);
      ("weekday_headings", weekday_headings lang);
      ("months", T.List months);
      ("days", T.List (List.map snd dvs)) ]