Source file printers.ml

(*********************************************************************************)
(*                Higlo                                                          *)
(*                                                                               *)
(*    Copyright (C) 2014-2021 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    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 Library General Public License for more details.                       *)
(*                                                                               *)
(*    You should have received a copy of the GNU Lesser 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                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*                                                                               *)
(*********************************************************************************)

(** *)

open Lang

type classes =
  {
    bcomment : string ;
    constant : string ;
    directive : string ;
    escape : string ;
    id : string ;
    keyword : int -> string ;
    lcomment : string ;
    numeric : string ;
    string : string ;
    symbol : int -> string ;
    text : string ;
  }

let default_classes = {
    bcomment = "comment" ;
    constant = "constant" ;
    directive = "directive" ;
    escape = "escape" ;
    id = "id" ;
    keyword = (function 0 -> "kw" | n -> "kw"^(string_of_int n)) ;
    lcomment = "comment" ;
    numeric = "numeric" ;
    string = "string" ;
    symbol = (function 0 -> "sym" | n -> "sym"^(string_of_int n)) ;
    text = "text" ;
  }
;;

let token_to node =
  fun ?(classes=default_classes) ->
    function
    | Bcomment s -> node classes.bcomment s
    | Constant s -> node classes.constant s
    | Directive s -> node classes.directive s
    | Escape s -> node classes.escape s
    | Id s -> node classes.id s
    | Keyword (n, s) -> node (classes.keyword n) s
    | Lcomment s -> node classes.lcomment s
    | Numeric s -> node classes.numeric s
    | String s -> node classes.string s
    | Symbol (n, s) -> node (classes.symbol n) s
    | Text s -> node classes.text s

let token_to_xml =
  let module X = Xtmpl.Xml in
  let node cl cdata =
    let atts = X.atts_one ("","class") (cl, None) in
    X.node ("","span") ~atts [X.cdata cdata]
  in
  token_to node
;;

let token_to_xml_rewrite =
  let module X = Xtmpl.Rewrite in
  let node cl cdata =
    let atts = X.atts_one ("","class") [X.cdata cl] in
    X.node ("","span") ~atts [X.cdata cdata]
  in
  token_to node
;;

let to_xml ?classes ~lang s =
  List.map (token_to_xml ?classes) (parse ~lang s)
;;

let to_xml_rewrite ?classes ~lang s =
  List.map (token_to_xml_rewrite ?classes) (parse ~lang s)
;;


type printer = Lang.token list -> unit

module SMap = Map.Make(String);;

let printers = ref SMap.empty ;;

let get_printer name =
  try SMap.find name !printers
  with Not_found -> failwith (Printf.sprintf "Unknown printer %S" name)
;;

let register_printer name f = printers := SMap.add name f !printers;;

let xml_printer tokens =
  let xmls = List.map token_to_xml tokens in
  print_string (Xtmpl.Xml.to_string xmls)
;;

let html_printer tokens =
  print_string "<html>
  <head>
    <meta content=\"text/html; charset=utf-8\" http-equiv=\"Content-Type\"/>
    <link href=\"style.css\" rel=\"stylesheet\" type=\"text/css\"/>
  </head>
  <body><pre>";
  xml_printer tokens;
  print_string "</pre></body></html>"
;;

let token_printer tokens =
  List.iter (fun t -> print_string (Lang.string_of_token t)) tokens
;;

let () =
  List.iter (fun (name, f) -> register_printer name f)
    [ "xml", xml_printer ;
      "html", html_printer ;
      "tokens", token_printer ;
    ]
;;