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)