Source file tags.ml

type status =
| Open_status
| Close_status

let make_high_color c = Style.(FG (Code (High, c))) [@@warning "-unused-value-declaration"]

let make_standard_color c = Style.(FG (Code (Standard, c)))

let make_bold = function
  | None -> [Style.Bold]
  | Some c -> Style.([make_standard_color c;Bold])

let make_underline = function
  | None -> [Style.Underline]
  | Some c -> Style.([make_standard_color c;Underline])

module ACG_Tags =
  struct
  type tag =
    | Lex
    | Sig
    | Fun
    | Term
    | Arg
    | Binary

  let tags =
    [ "sig", Sig, make_bold (Some Style.Green) ;
      "lex", Lex, make_bold (Some Style.Yellow) ;
      "fun", Fun, make_bold (Some Style.Red) ;
      "term", Term, make_bold (Some Style.Magenta) ;
      "arg", Arg, make_bold (Some Style.Blue) ;
      "bin", Binary, make_bold None ;
    ]

end

module Style_Tags =
  struct
    type tag =
      | Bold_tag
      | Blue_tag
      | Red_tag
      | Green_tag
      | Magenta_tag
      | Yellow_tag

    let tags = 
      [ "bold", Bold_tag, make_bold None ;
        "blue", Blue_tag, make_bold (Some Style.Blue) ;
        "red", Red_tag, make_bold (Some Style.Red) ;
        "green", Green_tag, make_bold (Some Style.Green);
        "magenta", Magenta_tag, make_bold (Some Style.Magenta);
        "yellow", Yellow_tag, make_bold (Some Style.Yellow);
      ]

  end

module Logs_Tags =
  struct
    type tag =
      | App
      | Err
      | Warn
      | Info
      | Debug

    let tags =
      [ "app", App, [make_standard_color Style.Cyan] ;
        "err", Err, [make_standard_color Style.Red] ;
        "warn", Warn, [make_standard_color Style.Yellow] ;
        "info", Info, [make_standard_color Style.Blue] ;
        "debug", Debug, [make_standard_color Style.Green] ;
      ]
  end

module Scripting_Tags =
  struct
    type tag =
      | Err_text

    let tags =
      [ "err_text", Err_text, make_underline (Some Style.Red) ;
      ]
  end

module ACG_Tags_Handler  = Style.Make_Handler (ACG_Tags)
module Style_Tags_Handler = Style.Make_Handler (Style_Tags)
module Logs_Tags_Handler  = Style.Make_Handler (Logs_Tags)
module Scripting_Tags_Handler  = Style.Make_Handler (Scripting_Tags)

let wrap tag ppf s = Format.fprintf ppf "@{<%s>%s@}" tag s

let bold_pp = wrap (Style_Tags_Handler.tag_to_name Style_Tags.Bold_tag)
let blue_pp = wrap (Style_Tags_Handler.tag_to_name Style_Tags.Blue_tag)
let red_pp = wrap (Style_Tags_Handler.tag_to_name Style_Tags.Red_tag)
let green_pp = wrap (Style_Tags_Handler.tag_to_name Style_Tags.Green_tag)
let magenta_pp = wrap (Style_Tags_Handler.tag_to_name Style_Tags.Magenta_tag)
let yellow_pp = wrap (Style_Tags_Handler.tag_to_name Style_Tags.Yellow_tag)


let app_pp = wrap (Logs_Tags_Handler.tag_to_name Logs_Tags.App)
let err_pp = wrap (Logs_Tags_Handler.tag_to_name Logs_Tags.Err)
let warn_pp = wrap (Logs_Tags_Handler.tag_to_name Logs_Tags.Warn)
let info_pp = wrap (Logs_Tags_Handler.tag_to_name Logs_Tags.Info)
let debug_pp = wrap (Logs_Tags_Handler.tag_to_name Logs_Tags.Debug)

let fun_pp = wrap (ACG_Tags_Handler.tag_to_name ACG_Tags.Fun)
let sig_pp = wrap (ACG_Tags_Handler.tag_to_name ACG_Tags.Sig)
let lex_pp = wrap (ACG_Tags_Handler.tag_to_name ACG_Tags.Lex)
let term_pp = wrap (ACG_Tags_Handler.tag_to_name ACG_Tags.Term)
let arg_pp = wrap (ACG_Tags_Handler.tag_to_name ACG_Tags.Arg)
let binary_pp = wrap (ACG_Tags_Handler.tag_to_name ACG_Tags.Binary)

let err_text_pp = wrap (Scripting_Tags_Handler.tag_to_name Scripting_Tags.Err_text)

type semtag =
  | Style of (Style_Tags.tag * Style.style list)
  | Logs of (Logs_Tags.tag * Style.style list)
  | ACG of (ACG_Tags.tag * Style.style list)
  | Scripting of (Scripting_Tags.tag * Style.style list)

module StringMap = Map.Make (String)

let semtags =
  let acg_tags =
    List.fold_left
      (fun acc (name, tag, att) -> StringMap.add name (ACG (tag, att)) acc)
      StringMap.empty
      ACG_Tags.tags in
  let style_tags =
    List.fold_left
      (fun acc (name, tag, att) -> StringMap.add name (Style (tag, att)) acc)
      acg_tags
      Style_Tags.tags in
  let scripting_tags =
    List.fold_left
      (fun acc (name, tag, att) -> StringMap.add name (Scripting (tag, att)) acc)
      style_tags
      Scripting_Tags.tags in
  List.fold_left
    (fun acc (name, tag, att) -> StringMap.add name (Logs (tag, att)) acc)
    scripting_tags
    Logs_Tags.tags


let stag_string_to_tag s =
  match String.split_on_char '/' s with
  | [""] -> failwith (Printf.sprintf "Bug: trying to parse an ill-formed semantic (empty) tag '%s'" s)
  | [tag] -> tag, Open_status
  | [""; _tag] -> failwith (Printf.sprintf "Bug: trying to parse an ill-formed closing semantic tag '%s'" s)
  | _ -> failwith (Printf.sprintf "Bug: trying to parse an ill-formed semantic tag '%s'" s)


let wrap_status styles = function
  | Open_status -> List.map (fun s -> Style.Open s) styles
  | Close_status -> List.rev_map (fun s -> Style.Close s) styles

let stag_to_style_tags = function
  | Format.String_tag s ->
     begin
       let tag, _status = stag_string_to_tag s in
       match StringMap.find_opt tag semtags with
       | None -> []
       | Some (ACG (_, att)) 
         | Some (Logs (_, att))
         | Some (Scripting (_, att))
         | Some (Style (_, att)) -> att (*wrap_status att status *)
     end
  | _ -> []

let add_marking ~render_mark formatter =
  let open Format in
  pp_set_mark_tags formatter true;
  let old_fs = pp_get_formatter_stag_functions formatter () in
  let start_mark_stag t = render_mark (wrap_status (stag_to_style_tags t) Open_status) in
  let stop_mark_stag _t = render_mark (wrap_status (stag_to_style_tags _t) Close_status) in
  pp_set_formatter_stag_functions formatter
    { old_fs with
      mark_open_stag = start_mark_stag;
      mark_close_stag = stop_mark_stag }