Source file texttag.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 T =
  struct
    module Id = Misc.Id()
    type t = Id.t
    type tag = {
        id: Id.t;
        name: string;
      }

    let tags = ref [| |]

    let tags_by_name = ref Smap.empty

    let create name =
      match Smap.find_opt name !tags_by_name with
      | None ->
          let t = { name ; id = Id.gen () } in
          let id_n = Id.to_int t.id in
          (match id_n with
           | 0 -> (* first id *)
               tags := Array.make 1 t;
           | n when n > 0 ->
               let tags2 = Array.make (id_n+1) t in
               Array.blit !tags 0 tags2 0 (Array.length !tags);
               tags := tags2
           | _ ->
               assert false
          );
          tags_by_name := Smap.add t.name t !tags_by_name ;
          t.id
       | Some t ->
          Log.warn (fun m -> m "Tag %S already exists" t.name);
          t.id

    let compare = Id.compare
    let equal t1 t2 = compare t1 t2 = 0

    let get id =
      let id_n = Id.to_int id in
      try Some (Array.get !tags id_n)
      with _ ->
        Log.err (fun m -> m "Invalid tag id %a" Id.pp id);
        None

    let name id =
      match get id with
      | None -> ""
      | Some t -> t.name

    let pp ppf id =
      match get id with
      | None -> ()
      | Some t ->
        Format.fprintf ppf
        "{id=%a; name=%S}" Id.pp t.id t.name

    let table name =
      let t = ref Misc.IMap.empty in
      let get n =
        match Misc.IMap.find_opt n !t with
        | None ->
            let tag = create (Printf.sprintf "%s%d" name n) in
            t := Misc.IMap.add n tag !t;
            tag
        | Some tag -> tag
      in
      let elements () = Misc.IMap.bindings !t in
      (get, elements)

    let get_or_create str =
      match Smap.find_opt str !tags_by_name with
      | None -> create str
      | Some t -> t.id

    let tags () = List.map (fun t -> t.id) (Array.to_list !tags)
  end

type tag = T.t

module TMap = Map.Make(T)
module TSet = Misc.Idset(T.Id)
(*module Mem = Misc.Memoizer(struct
     type t = TSet.t
     let compare = TSet.compare
     let dup x = x
   end)
*)

let pp_list ppf l =
  List.iter
    (fun t -> Format.fprintf ppf "%a\n" T.pp t)
    l

let pp_set ppf set = pp_list ppf (TSet.to_list set)

let tag_debug = T.create "debug"
let tag_info = T.create "info"
let tag_warning = T.create "warning"
let tag_error = T.create "error"
let tag_app = T.create "app"

let log_tags = [ tag_debug ; tag_info ; tag_warning ; tag_error ; tag_app ]

module Lang =
  struct
    let bcomment = T.create "bcomment"
    let constant = T.create "constant"
    let directive = T.create "directive"
    let escape = T.create "escape"
    let id = T.create "id"

    let keyword = T.table "keyword"
    let keyword0 = fst keyword 0
    let keyword1 = fst keyword 1
    let keyword2 = fst keyword 2
    let keyword3 = fst keyword 3
    let keyword4 = fst keyword 4

    let lcomment = T.create "lcomment"
    let numeric = T.create "numeric"
    let string = T.create "string"

    let symbol = T.table "symbol"
    let symbol0 = fst symbol 0
    let symbol1 = fst symbol 1

    let title = T.table "title"
    let title0 = fst title 0
    let title1 = fst title 1
    let title2 = fst title 2
    let title3 = fst title 3
    let title4 = fst title 4
    let title5 = fst title 5
    let title6 = fst title 6

    let tag_of_token = function
    | Higlo.Lang.Bcomment (_,size) -> Some bcomment, size
    | Constant (_,size) -> Some constant, size
    | Directive (_,size) -> Some directive, size
    | Escape (_,size) -> Some escape, size
    | Id (_,size) -> Some id, size
    | Keyword (n, (_,size)) -> Some (fst keyword n), size
    | Lcomment (_,size) -> Some lcomment, size
    | Numeric (_,size) -> Some numeric, size
    | String (_,size) -> Some string, size
    | Symbol (n, (_, size)) -> Some (fst symbol n), size
    | Text (_,size) -> None, size
    | Title (n, (_, size)) -> Some (fst title n), size

    let tags = [ bcomment ; constant ; directive ; escape ; id ;
        keyword0 ; keyword1 ; keyword2 ; keyword3 ; keyword4 ;
        lcomment ; numeric ; string ; symbol0 ; symbol1 ;
        title0 ; title1 ; title2 ; title3 ; title4 ; title5 ; title6
      ]

  end

module Theme =
  struct
    module Id = Misc.Id()
    type t = { id : Id.t; mutable tags : Props.t TMap.t }
    let equal t1 t2 = Id.equal t1.id t2.id
    let tags_props_differ t1 t2 = TMap.compare Props.compare t1.tags t2.tags <> 0

    let pp ppf t =
      Format.fprintf ppf "@[Tagtheme %a {@." Id.pp t.id ;
      Format.pp_open_box ppf 2;
      TMap.iter (fun t props ->
        Format.fprintf ppf "%a -> %a@." T.pp t Props.pp props)
        t.tags;
      Format.pp_close_box ppf ();
      Format.fprintf ppf "@]}"

    let set_tag t tag props = t.tags <- TMap.add tag props t.tags

    let opt_props t tag = TMap.find_opt tag t.tags
    let tag_props t tag =
      match opt_props t tag with
      | None ->
          let p = Props.empty () in
          set_tag t tag p;
          p
      | Some p -> p

    let set_tag_prop t (tag:T.t) p v =
      let props =
        match opt_props t tag with
        | None ->
            let p = Props.empty () in
            t.tags <- TMap.add tag p t.tags;
            p
        | Some p -> p
      in
      Props.set props p v

    let merge_tag_props =
      let f t tag acc =
        match opt_props t tag with
        | None -> acc
        | Some p -> Props.merge acc p
      in
      fun t tags props -> List.fold_right (f t) (TSet.to_list tags) props

    let merge_tags =
      let merge k v1 v2 =
        match v1, v2 with
        | None, _ -> v2
        | Some _, None -> v1
        | _, Some _ -> v2
      in
      fun tags1 tags2 -> TMap.merge merge tags1 tags2

    let create ?(tags=TMap.empty) () = { id = Id.gen () ; tags }

    let tags_props t =
      List.fold_left (fun acc tag ->
         let p = tag_props t tag in
         (tag,p) :: acc)
        [] (T.tags())

(*
      let p = Props.empty () in
      let tags = TMap.empty in
      (* set general theme properties *)
      Props.set_from_json ~vars:Theme.(variables (snd (current_theme()))) p json;
      let p, tags =
        match json with
        | `Assoc l ->
            (match List.assoc_opt "inherits" l with
             | None -> (p, tags)
             | Some (`String s) -> apply_inherits (p, tags) s
             | Some (`List l) ->
                 List.fold_left (fun (p, tags) -> function
                  | `String s -> apply_inherits (p, tags) s
                  | json -> invalid_json json "string"; (p, tags))
                   (p, tags) l
             | Some json -> invalid_json json "string or string list"; (p, tags)
           )
       | _ -> (p, tags)
      in
      let t = get_or_create ~tags ~props:p name in
      ( (* set tag properties *)
       match json with
       | `Assoc l ->
           (match List.assoc_opt "tags" l with
            | None -> ()
            | Some (`Assoc l) ->
               List.iter
                  (fun (tag_name, json) ->
                     let tag = T.get_or_create tag_name in
                     let p = tag_props t tag in
                     Props.set_from_json
                       ~vars:Theme.(variables (snd (current_theme()))) p json
                  )
                  l
            | Some json ->
                invalid_json json "object";
                ()
           )
       | _ -> ()
      );
      t

    let to_json t =
      let tags = TMap.fold
        (fun tag props acc ->
           (T.name tag, Props.to_json props) :: acc)
          t.tags []
      in
      match Props.to_json t.props with
      | `Assoc l -> `Assoc (("tags", `Assoc tags) :: l)
      | _ -> Log.err (fun m -> m "invalid json for props"); assert false

    let themes_of_json = function
    | `Assoc l ->
        List.map
          (fun (name, json) -> from_json name json)
          l
    | json -> Ocf.invalid_value json

    let default = get_or_create "default"
*)
    let init () = ()
    let prop =
      Props.string_prop ~after:[Resize]
        ~default:"default"
        ~inherited:true "tagtheme"
      let css_prop = Theme.string_prop prop
  end



(*
| Bcomment (_,size) -> Printf.sprintf "Bcomment(%S)" s
| Constant (_,size) -> Printf.sprintf "Constant(%S)" s
| Directive (_,size) -> Printf.sprintf "Directive(%S)" s
| Escape (_,size) -> Printf.sprintf "Escape(%S)" s
| Id (_,size) -> Printf.sprintf "Id(%S)" s
| Keyword (n, (s, _)) -> Printf.sprintf "Keyword(%d, %S)" n s
| Lcomment (_,size) -> Printf.sprintf "Lcomment(%S)" s
| Numeric (_,size) -> Printf.sprintf "Numeric(%S)" s
| String (_,size) -> Printf.sprintf "String(%S)" s
| Symbol (n, (s, _)) -> Printf.sprintf "Symbol(%d, %S)" n s
| Text (_,size) -> Printf.sprintf "Text(%S)" s
*)