Source file highlight.ml

(*********************************************************************************)
(*                Stog                                                           *)
(*                                                                               *)
(*    Copyright (C) 2012-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 XR = Xtmpl.Rewrite

let external_highlight ~opts code =
  let code_file = Filename.temp_file "stog" "code" in
  Stog_base.Misc.file_of_string ~file: code_file code;
  let temp_file = Filename.temp_file "stog" "highlight" in
  let com = Printf.sprintf
    "highlight -O xhtml %s -f %s > %s"
    opts (Filename.quote code_file)(Filename.quote temp_file)
  in
  match Sys.command com with
    0 ->
      let code = Stog_base.Misc.string_of_file temp_file in
      Sys.remove code_file;
      Sys.remove temp_file;
      let code = Stog_base.Misc.strip_string code in
      XR.from_string code
  | _ ->
      failwith (Printf.sprintf "command failed: %s" com)
;;

let higlo_classes =
  let keyword = function
    0 -> "hl kwa"
  | 1 -> "hl kwb"
  | 2 -> "hl kwc"
  | 3 -> "hl kwd"
  | n -> "hl kw"^(string_of_int n)
  in
  let symbol _ = "sym" in
  let title n = Printf.sprintf "h%d" n in
  {
    Higlo.Printers.id = "" ;
    keyword ;
    lcomment = "hl slc" ;
    bcomment = "hl com" ;
    string = "hl str" ;
    text = "hl std" ;
    numeric = "hl num" ;
    directive = "hl dir" ;
    escape = "hl esc" ;
    symbol ;
    constant = "hl num" ;
    title ;
  }
;;

let unknown_lang_warned = ref Types.Str_set.empty

let highlight ?lang ?opts code =
  match lang, opts with
    None, Some opts
  | Some "", Some opts -> external_highlight ~opts code
  | None, None
  | Some "", None -> [XR.cdata code]
  | Some lang, Some opts ->
      let opts = opts^" --syntax="^lang in
      external_highlight ~opts code
  | Some "txt", None ->
      let len = String.length code in
      [ Higlo.Printers.token_to_xml_rewrite ~classes: higlo_classes (Higlo.Lang.Text (code, len)) ]
  | Some lang, None ->
      try
        let _lexer = Higlo.Lang.get_lexer lang in
        Higlo.Printers.to_xml_rewrite ~classes: higlo_classes ~lang code
      with
        Higlo.Lang.(Error (Unknown_lang s)) ->
          if not (Types.Str_set.mem s !unknown_lang_warned) then
            ( unknown_lang_warned := Types.Str_set.add s !unknown_lang_warned ;
             Log.warn
               (fun m -> m "Higlo: unknown language %s. Falling back to external highlight" lang)
            );
          let opts = " --syntax="^lang in
          external_highlight ~opts code
;;