Source file layout.ml

(*********************************************************************************)
(*                OCaml-Stk                                                      *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU General Public License as                    *)
(*    published by the Free Software Foundation, version 3 of the License.       *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the               *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public                  *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

module WMap = Stk.Widget.Map

type of_node =
    { ctx : ctx ;
      widget : Stk.Widget.widget option ;
      before : Stk.Widget.widget option ;
      after : Stk.Widget.widget option ;
      subs_handled: bool;
    }

and of_node_fun = ctx -> Xml.node -> of_node option
and ctx =
    {
      of_node : of_node_fun ;
      container : Stk.Widget.widget ;
      css_rules : Iri.t Css.S.rule_ list ;
      root_props : Css.C.t ;
      props : Css.C.t ;
      font_desc : Stk.Font.font_desc ;
      path : Xml.node list list ;
      nodes: Doc.node list ;
      node_count : int ;
      item_map : Doc.node WMap.t ;
      id_map : Doc.node Stk.Smap.t ;
      load_resource : Iri.t -> [`None | `Error of string | `Ok of Ldp.Types.resource] Lwt.t;
      iri : Iri.t option ;
      base_iri : Iri.t option;
  }

let of_node_none ctx =
  { ctx ; widget = None ; before = None ; after = None ; subs_handled = false }

let pack ~(container:Stk.Widget.widget) ?kind (w:Stk.Widget.widget) =
  match container#typ with
  | Some (Stk.Flex.Flex flex) -> flex#pack ?kind w
  | Some (Stk.Table.Table _) -> ()
  | _ -> Log.err (fun m -> m "Layout.pack: Container %s is not a flex" container#me)

let pack_break (container:Stk.Widget.widget) ?props () =
  match container#typ with
  | Some (Stk.Flex.Flex flex) -> Some (flex#pack_break ?props ())#coerce
  | Some (Stk.Table.Table _) -> None
  | _ ->
      Log.err (fun m -> m "Layout.pack_break: Container %s is not a flex" container#me);
      None

let pack_space (container:Stk.Widget.widget) ?props () =
  match container#typ with
  | Some (Stk.Flex.Flex flex) -> Some (flex#pack_space ?props ())#coerce
  | Some (Stk.Table.Table _) -> None
  | _ ->
      Log.err (fun m -> m "Layout.pack_space: Container %s is not a flex" container#me);
      None

let build_text ctx cdata =
  let p = Props.props_of_css_props ctx.props in
  (* FIXME: rather than setting text padding to 0, we should apply the block
     padding to elements on the border: left padding for first label, right
     padding for last label. Problem is how to handle top and bottom padding,
     since it depends on the final disposition in parent widget.*)
  Stk.Props.(set p padding (trbl__ 0));
  Stk.Props.(set p margin (trbl__ 0));
  let w =
    match cdata.Xtmpl.Types.text with
    | "\n" -> pack_break ctx.container ~props:p ()
    | " " -> pack_space ctx.container ~props:p ()
    | s ->
        let t = Stk.Text.label ~props:p ~text:s () in
        pack ctx.container t#coerce ;
        Some t#coerce
  in
  w

(* xml should be provided to link to original xml tree.
   If no xml is provided, this is some additional text (list item bullets,
   typically) and in this case we set the widget Stk text property. *)
let add_cdata ctx ?xml cdata =
  let widget = build_text ctx cdata in
  let node =
    { Doc.xml ; widget ;
      subs = [] ;
      id = None ;
      container = ctx.container ;
      parent = None ;
      props = ctx.props ;
      display = true ;
    }
  in
  let item_map =
    match widget with
    | None ->
        [%debug  "Layout.add_cdata: no widget"];
        ctx.item_map
    | Some wid ->
        (match xml with None -> wid#set_p Stk.Props.text cdata.text | Some _ -> ());
        let (w, h) = let g = wid#geometry in (g.w, g.h) in
        [%debug  "size(%S) = (%d, %d)" cdata.text w h];
        let item_map = WMap.add wid node ctx.item_map in
        Eprops.connect_event_props ctx.props wid node ;
        item_map
  in
  { ctx with nodes = node :: ctx.nodes ;
    node_count = ctx.node_count + 1 ;
    item_map ;
  }

let build_image ctx width height props =
  let image = Stk.Image.image ?width ?height ~props
    ~pack:(pack ~container:ctx.container) ()
  in
  image

let image_from_ressource g ?width ?height = function
| Ldp.Types.Rdf _
| Ldp.Types.Container _ -> Lwt.return_none
| Ldp.Types.Non_rdf r ->
  let ct = r.Ldp.Types.ct in
  match%lwt
    match ct.Ldp.Ct.ty, ct.Ldp.Ct.subty with
    | Ldp.Ct.Image, s ->
        let typ =
          if Stk.Misc.is_prefix ~s ~pref:"svg" then `Svg else `Other
        in
        (
         match snd Ldp.Types.(r.meta.info) with
         | `Empty -> Lwt.return_none
         | `String s -> Lwt.return_some (s, typ)
         | `Strings l -> Lwt.return_some (String.concat "" l, typ)
         | `Stream s ->
             let%lwt l = Lwt_stream.to_list s in
             Lwt.return_some (String.concat "" l, typ)
        )
    | _ -> Lwt.return_none
  with
  | None -> Lwt.return_none
  | Some (s, _typ) -> Lwt.return_some s

let load_image ctx props image iri =
  match%lwt ctx.load_resource iri with
  | `None -> Lwt.return_unit
  | `Error msg ->
      Log.err (fun m -> m "Error while loading %s: %s" (Iri.to_string iri) msg);
      Lwt.return_unit
  | `Ok r ->
      match%lwt image_from_ressource ctx r with
      | None -> Lwt.return_unit
      | Some str ->
          let open Stk.Misc in
          let> rw = Tsdl.Sdl.rw_from_const_mem str in
          image#load_rw rw;
          (*Stk.Log.warn (fun m -> m "image %s loaded" (Iri.to_string iri));*)
          match image#width with
          | Some _ -> Lwt.return_unit
          | None ->
              match image#image_size with
              | None -> Lwt.return_unit
              | Some (wi,_) ->
                  let max_w =
                    match Props.max_abs_width_of_css ctx.props with
                    | None -> None
                    | Some w ->
                        if w > 0 then Some (min w wi) else None
                  in
                  (*Stk.Log.warn (fun m -> m "max_width: %s"
                    (match max_w with None -> "None" | Some d -> string_of_int d));*)
                  Option.iter image#set_width max_w ;
                  Lwt.return_unit


let image ctx ?xml iri node =
  [%debug "adding image from %a" Iri.pp iri];
  match Xml.opt_att node ~try_no_ns:true (Xml.empty_iri, "src") with
  | None -> of_node_none ctx
  | Some (iri_s, _) ->
      match Iri.of_string iri_s with
      | exception e ->
          Log.warn (fun m -> m "Invalid image href: %s" (Printexc.to_string e));
          of_node_none ctx
      | iri ->
          let iri = match ctx.iri with
            | None -> iri
            | Some base -> Iri.resolve ~normalize:false ~base iri
          in
          Log.info (fun m -> m "original iri: %s, looked up iri: %s" iri_s (Iri.to_string iri));
          let width =
            match Xml.opt_int_att node (iri, "width") with
            | Some n -> Some n
            | None -> Props.get_css_length ctx.props Css.P.width
          in
          let height =
            match Xml.opt_int_att node (iri, "height") with
            | Some n -> Some n
            | None -> Props.get_css_length ctx.props Css.P.height
          in
          let image = build_image ctx width height (Props.props_of_css_props ctx.props) in
          Lwt.async (fun () -> load_image ctx ctx.props image iri);
          { ctx ;
            widget = Some image#coerce ;
            before = None ; after = None ;
            subs_handled = false ;
          }

let set_container_borders (w:Stk.Widget.widget) (props:Css.C.t) =
  let border_widths = Props.border_widths_of_css props in
  let border_colors = Props.border_colors_of_css props in
  w#set_p Stk.Props.border_width border_widths ;
  w#set_p Stk.Props.border_color border_colors ;
  ()

let flex_of_props ?name props =
  let p = Props.props_of_css_props props in
  let flex = Stk.Flex.flex ?name ~inter_space:0 ~props:p () in
  (*Log.warn (fun m -> m "flex %s built with props %a" flex#me Stk.Props.pp p);*)
  (*Stk.Log.warn (fun m -> m "%s created with font_desc=%a"
     flex#me Stk.Font.pp_font_desc (flex#get_p Stk.Props.font_desc));*)
  flex

let table_of_props ?name props =
  let p = Props.props_of_css_props props in
  let table = Stk.Table.table ?name ~props:p () in
  table#set_hfill false;
  (*Stk.Log.warn (fun m -> m "%s created with font_desc=%a"
     flex#me Stk.Font.pp_font_desc (flex#get_p Stk.Props.font_desc));*)
  table

let ctx_new_block ~name ctx =
  let g = flex_of_props ~name ctx.props in
  pack ~container:ctx.container ~kind:`Block g#coerce;
  g#set_p Stk.Flex.expand 1;
  { ctx with container = g#coerce }

let table_current_row = Stk.Props.int_prop
  ~default:(-1) ~inherited:false "table-current-row"
let table_current_column = Stk.Props.int_prop
  ~default:(-1) ~inherited:false "table-current-column"

let table_container ctx =
  match ctx.container#typ with
  | Some Stk.Table.Table t -> Some t
  | _ ->
      Log.warn (fun m -> m "Stk_xml.Layout: %s is not a table" ctx.container#me);
      None

let of_node_table_row ctx ?name node =
  match table_container ctx with
  | None -> of_node_none ctx
  | Some table ->
      let cur_row = table#get_p table_current_row in
      let row = cur_row + 1 in
      let rows = table#rows in
      if rows < row + 1 then table#set_rows (row + 1);
      table#set_p table_current_row row;
      table#set_p table_current_column (-1);
      of_node_none ctx

let set_table_collapse_cell_borders table row col (w:Stk.Widget.widget) =
  (* we set borders then remove left and top borders as they
     are covered by previous cells or table border. *)
  let trbl0 = w#border_width in
  let tab_bc = table#border_color in
  let tab_bw = table#border_width in
  let trbl2 =
    let open Stk.Props in
    let w,c =
      match table#widget_at ~row ~column:(col-1) with
      | None when col > 0 -> 0, Stk.Color.transparent
      | None -> tab_bw.left, tab_bc.left
      | Some w -> w#border_width.right, w#border_color.right
    in
    if w <= 0 || c = Stk.Color.transparent then
      trbl0
    else
      { trbl0 with left = 0 }
  in
  let trbl2 =
    let w,c =
      match table#widget_at ~row:(row-1) ~column:col with
      | None when row > 0 -> 0, Stk.Color.transparent
      | None -> tab_bw.top, tab_bc.top
      | Some w -> w#border_width.bottom, w#border_color.bottom
    in
    if w <= 0 || c = Stk.Color.transparent then
      trbl2
    else
      { trbl2 with top = 0 }
  in
  if trbl2 <> trbl0 then w#set_border_width trbl2

let of_node_table_cell ctx ?name node =
  match table_container ctx with
  | None -> of_node_none ctx
  | Some table ->
      let row = table#get_p table_current_row in
      let row = if row < 0 then
          (table#set_rows (max table#rows 1);
           table#set_p table_current_row 0;
           0
          )
        else
          row
      in
      let col = table#get_p table_current_column in
      let col = col + 1 in
      let columns = table#columns in
      if columns < col + 1 then table#set_columns (col + 1);
      table#set_p table_current_column col;
      [%debug "table: %d rows, %d columns" table#rows table#columns];
      let flex = flex_of_props ?name ctx.props in
      set_container_borders flex#coerce ctx.props;
      (match Css.(C.get ctx.props P.border_collapse) with
       | `Separate -> ()
       | `Collapse -> set_table_collapse_cell_borders table row col flex#coerce
      );
      table#pack ~pos:(row,col) flex#coerce ;
      { ctx = { ctx with container = flex#coerce };
        widget = Some flex#coerce ;
        before = None ; after = None ; subs_handled = false }

let of_node_table_caption ctx ?name node = of_node_none ctx

let of_display_inside ~name ctx new_block = function
| `Table ->
    let g = table_of_props ~name ctx.props in
    (* we pack table as block only if a new block (i.e. a new flex)
       was created; else we pack it normally *)
    let kind = if new_block then Some `Block else None in
    pack ?kind ~container:ctx.container g#coerce ;
    g#set_p Stk.Flex.expand 1;
    Some g#coerce
| `Flex
| `Flow_root ->
    if new_block then
      None
    else
      (
       let g = flex_of_props ~name ctx.props in
       [%debug "of_display_inside, created flex %s in parent %s, as %s"
          g#me ctx.container#me (Stk.Flex.string_of_item_kind (g#get_p Stk.Flex.item_kind))];
       pack ~container:ctx.container g#coerce;
       g#set_p Stk.Flex.expand 1;
       Some g#coerce
      )
| `Grid
| `Ruby
| `Flow -> None

let default_of_node ctx node =
  let (iri, name) = node.Xml.name in
  match name with
  | "img" when Iri.equal iri  Xml.xhtml_ns ->
      image ctx ~xml:(Xml.E node) iri node
  | _ ->
      let display = Css.(C.get ctx.props P.display) in
      (*Log.debug (fun m -> m "display=%a" Css.T.pp_display display);*)
      match display with
      | `Out_in (outside, inside, li) ->
          let ctx, new_block =
            match outside, inside with
            | `Block, `Table -> ctx, true
            | `Block, _ -> ctx_new_block ~name ctx, true
            | _ -> ctx, false
          in
          let new_container = of_display_inside ~name ctx new_block inside in
          let of_node =
            match new_block, new_container with
            | true, None ->
                set_container_borders ctx.container ctx.props ;
                { ctx ;
                  widget = Some ctx.container#coerce ;
                  before = None; after = None ;
                  subs_handled = false ;
                }
            | false, None -> of_node_none ctx
            | true, Some c ->
                set_container_borders c ctx.props ;
                { ctx = { ctx with container = c } ;
                  widget = Some ctx.container ;
                  before = None ; after = None ;
                  subs_handled = false ;
                }
            | false, Some c ->
                set_container_borders c ctx.props ;
                { ctx = { ctx with container = c } ;
                  widget = Some c ;
                  before = None ; after = None ;
                  subs_handled = false ;
                }
          in
          let of_node =
            match li with
            | Some `List_item ->
                let p = Props.props_of_css_props ctx.props in
                let w = Stk.Text.label ~props:p ~text:"• " () in
                { of_node with
                  before = Some w#coerce ;
                  after = None ;
                }
            | None -> of_node
          in
          of_node
      | `None ->
          let g = flex_of_props ~name ctx.props in
          pack ctx.container g#coerce;
          g#set_p Stk.Flex.expand 1;
          g#set_visible false ;
          { ctx = { ctx with container = g#coerce } ;
            widget = Some g#coerce ;
            before = None ; after = None ;
            subs_handled = false ;
          }
      | `Table_row_group
      | `Table_header_group
      | `Table_footer_group -> of_node_none ctx
      | `Table_row -> of_node_table_row ctx ~name node
      | `Table_cell -> of_node_table_cell ctx ~name node
      | `Table_caption -> of_node_table_caption ctx ~name node
      | `Table_column_group
      | `Table_column as d ->
          [%debug "display %a not handled, acting like inline" Css.T.pp_display d];
          of_node_none ctx
      | d ->
          [%debug "display %a not handled, acting like inline" Css.T.pp_display d];
          of_node_none ctx

let add_widget ctx w =
  let n = {
      Doc.xml = None ; widget = Some w;
      subs = [] ;
      id = None;
      container = ctx.container ;
      parent = None ;
      props = ctx.props ;
      display = w#visible ;
    }
  in
  let item_map = Doc.WMap.add w n ctx.item_map in
  pack ctx.container w;
  { ctx with
    nodes = n :: ctx.nodes ;
    node_count = ctx.node_count + 1 ;
    item_map ;
  }

let rec doc_of_node ctx ({ Xml.name = (iri, name) } as node) =
  (*Log.warn (fun m -> m "Element %a" Xml.P.pp_name node.name);*)
  let path =
    match ctx.path with
    | [] -> [[node]]
    | h :: q -> (node :: h) :: q
  in
  let props = Style.get_props ~honor_style_attr:true
    ctx.path ~root:ctx.root_props
      ~parent:ctx.props ctx.css_rules node
  in
  (*Log.warn (fun m -> m "path=%a, props=%a" Style.pp_path path Css.C.pp props);*)
  let id = Xml.node_id node in
  let of_node =
    let ctx2 = { ctx with props ; path } in
    match ctx.of_node ctx2 node with
    | Some x -> x
    | None -> default_of_node ctx2 node
  in
  let container = of_node.ctx.container in
  let ctx2 = { of_node.ctx with
      font_desc = Stk.Props.(get container#props font_desc) ;
    }
  in
  container#ignore_need_resize ;
  let ctx2 =
    match of_node.before with
    | None -> ctx2
    | Some w -> add_widget ctx2 w
  in
  let subctx =
    if of_node.subs_handled then
      ctx2
    else
      let subctx = doc_of_xmls ctx2 node.subs in
      { subctx with nodes = List.rev subctx.nodes }
  in
  let subctx =
    match of_node.after with
    | None -> subctx
    | Some w -> add_widget subctx w
  in
  let widget = of_node.widget in
  let n = {
      Doc.xml = Some (Xml.E node) ; widget ;
      subs = subctx.nodes ;
      id ; container = ctx.container ;
      parent = None ;
      props ;
      display = (match widget with None -> true | Some w -> w#visible) ;
    }
  in
  Option.iter (fun w -> Eprops.connect_event_props props w n) (Doc.node_widget n);
  container#handle_need_resize ;
  List.iter (fun sub -> sub.Doc.parent <- Some n) n.subs ;
  let id_map =
    match id with
    | None -> subctx.id_map
    | Some s -> Stk.Smap.add s n subctx.id_map
  in
  let item_map = match of_node.widget with
    | None -> subctx.item_map
    | Some w -> Doc.WMap.add w n subctx.item_map
  in
  { ctx with
    nodes = n :: ctx.nodes ;
    path = ctx2.path ;
    node_count = ctx.node_count + 1 + subctx.node_count ;
    item_map ; id_map ;
  }

and doc_of_xml ctx xml =
  let open Xml in
  match xml with
  | C _ | PI _ -> ctx
  | D cdata -> add_cdata ctx ~xml cdata
  | E node -> doc_of_node ctx node

and doc_of_xmls ctx xmls =
  let ctx2 = { ctx with nodes = [] ; node_count = 0 ; path = [] :: ctx.path } in
  let ctx2 = List.fold_left doc_of_xml ctx2 xmls in
  { ctx2 with node_count = ctx.node_count + ctx2.node_count ; path = ctx.path }

let build_doc ?of_node iri load_resource set_widget style xmls =
  let of_node = match of_node with
        | None -> (fun _ _ -> None)
        | Some f -> f
  in
  let xmls = Xml.normalize_xmls xmls in
  let t1 = Unix.times () in
  let flex = Stk.Flex.flex ~wrap:true ~collapse_spaces:true ~pack:set_widget () in
  flex#ignore_need_resize ;
  let base_iri = Option.map (Xml.xhtml_base xmls) iri in
  let root_props =
    let node = Xml.node_ (Iri.of_string "", ":root") [] in
    let p = Style.get_props [] style node in
    [%debug "Root props (node %S) = %a" (Xml.QName.to_string node.Xml.name) Css.C.pp p];
    p
  in
  let ctx = {
      of_node ;
      css_rules = style ;
      root_props ;
      props = root_props ;
      font_desc = Stk.Font.default_font_desc ;
      container = flex#coerce ;
      path = [] ;
      nodes = [] ;
      node_count = 0 ;
      item_map = WMap.empty ;
      id_map = Stk.Smap.empty ;
      load_resource ;
      iri ;
      base_iri ;
    }
  in
  let ctx = doc_of_xmls ctx xmls in
  flex#handle_need_resize ;
  flex#need_resize;
  [%debug "%s#geometry=%a, width_constraints=%a, g_arranged=%a"
    flex#me Stk.G.pp flex#geometry
      Stk.Widget.pp_size_constraints flex#width_constraints Stk.G.pp
      (Option.value ~default:Stk.G.zero flex#g_arranged)];
  let t2 = Unix.times () in
  Log.info (fun m ->
    Unix.(m "building nodes: user:%.2f, sys:%.2f"
      (t2.tms_utime -. t1.tms_utime) (t2.tms_stime -. t1.tms_stime)));
  let doc = {
      Doc.doc_nodes = List.rev ctx.nodes ;
      doc_item_map = ctx.item_map ;
      doc_id_map = ctx.id_map ;
      doc_filter = None ;
      doc_text_index = None ;
    }
  in
  (doc, ctx.node_count)