Source file cmly_read.ml

(******************************************************************************)
(*                                                                            *)
(*                                    Menhir                                  *)
(*                                                                            *)
(*   Copyright Inria. All rights reserved. This file is distributed under     *)
(*   the terms of the GNU Library General Public License version 2, with a    *)
(*   special exception on linking, as described in the file LICENSE.          *)
(*                                                                            *)
(******************************************************************************)

open Cmly_format
open Cmly_api

exception Error of string

(* ------------------------------------------------------------------------ *)

(* Reading a .cmly file from a channel. *)

let read_channel (ic : in_channel) : grammar =
  (* .cmly file format: CMLY ++ version string ++ grammar *)
  let magic = "CMLY" ^ Version.version in
  try
    let m = really_input_string ic (String.length magic) in
    if m <> magic then
      raise (Error (Printf.sprintf "Invalid magic string in .cmly file.\n\
                 Expecting %S, but got %S." magic m))
    else
      (input_value ic : grammar)
  with
  | End_of_file  (* [really_input_string], [input_value] *)
  | Failure _ -> (* [input_value] *)
      raise (Error (Printf.sprintf "Invalid or damaged .cmly file."))

(* Reading a .cmly file based on its filename. *)

let read (filename : string) : grammar =
  let ic = open_in_bin filename in
  match read_channel ic with
  | x ->
      close_in_noerr ic;
      x
  | exception exn ->
      close_in_noerr ic;
      raise exn

(* ------------------------------------------------------------------------ *)

(* Reading a .cmly file whose content is stored in a string. *)

let starts_with prefix s =
  String.(length prefix <= length s && prefix = sub s 0 (length prefix))

let from_string (content : string) : grammar =
  (* .cmly file format: CMLY ++ version string ++ grammar *)
  let magic = "CMLY" ^ Version.version in
  if starts_with magic content then
    try
      Marshal.from_string content (String.length magic)
    with Failure _ ->
      raise (Error (Printf.sprintf "Invalid or damaged .cmly file."))
  else
    let m = String.(sub content 0 (min (length magic) (length content))) in
    raise (Error (Printf.sprintf "Invalid magic string in .cmly file.\n\
               Expecting %S, but got %S." magic m))

(* ------------------------------------------------------------------------ *)

(* Packaging the interval [0..count) as a module of type [INDEXED]. *)

module Index (P : sig
  val name: string (* for error messages only *)
  val count: int
end)
: INDEXED with type t = int
= struct

  type t = int

  let count = P.count

  let of_int n =
    if 0 <= n && n < count then n
    else invalid_arg (P.name ^ ".of_int: index out of bounds")

  let to_int n = n

  let hash n = n

  let equal (i : int) (j : int) = i = j

  let compare (i : int) (j : int) = i - j (* OK for integers of small magnitude *)

  let iter f =
    for i = 0 to count - 1 do
      f i
    done

  let fold f x =
    let r = ref x in
    for i = 0 to count - 1 do
      r := f i !r
    done;
    !r

  let tabulate f =
    let a = Array.init count f in
    Array.get a

end

(* ------------------------------------------------------------------------ *)

(* Packaging a data structure of type [Cmly_format.grammar] as a module
   of type [Cmly_api.GRAMMAR]. *)

module Lift (G : sig val grammar : grammar end) : GRAMMAR = struct
  open G

  type terminal    = int
  type nonterminal = int
  type production  = int
  type lr0         = int
  type lr1         = int
  type item        = production * int
  type ocamltype   = string
  type ocamlexpr   = string
  type identifier = string


  module Range = struct

    type t =
      Cmly_format.range

    let startp range =
      range.r_start

    let endp range =
      range.r_end

  end

  type 'a located = 'a * Range.t

  module Attribute = struct

    type t =
      Cmly_format.attribute

    let label attr =
      attr.a_label

    let has_label label attr =
      label = attr.a_label

    let payload attr =
      attr.a_payload

    let position attr =
      attr.a_position

  end

  module Action = struct
    type t = action
    let expr      t = t.a_expr
    let keywords  t = t.a_keywords
  end

  module Surface = struct
    type filename = string
    type name = string

    module Priority_level = struct
      type t = priority_level
      let input_file t = t.pl_input_file
      let level      t = t.pl_level
    end

    module Producer = struct
      type 'sym t = 'sym producer_def
      let symbol     (x,_,_) = x
      let identifier (_,x,_) = x
      let attributes (_,_,x) = x
    end

    module Branch = struct
      type 'sym t = 'sym surface_branch
      let position         t = t.br_position
      let producers        t = t.br_producers
      let action           t = t.br_action
      let prec_annotation  t = t.br_prec_annotation
      let production_level t = t.br_production_level
      let attributes       t = t.br_attributes
    end

    module Parameter = struct
      type t = parameter
      type desc =
        | Var of name
        | App of name * t list
        | Anonymous of t Branch.t list

      let desc = function
        | ParameterVar (x, _) -> Var x
        | ParameterApp ((x, _), xs) -> App (x, xs)
        | ParameterAnonymous (x, _) -> Anonymous x

      let located ( ParameterVar (_, pos)
                  | ParameterApp ((_, pos), _)
                  | ParameterAnonymous (_, pos)) =
        pos
    end

    module Rule = struct
      type ('param, 'sym) t = ('param, 'sym) surface_rule
      let parameters t = t.r_parameters
      let branches   t = t.r_branches
      let inline     t = t.r_inline
      let positions  t = t.r_positions
      let public     t = t.r_public
      let attributes t = t.r_attributes
    end

    module Token = struct
      type t = surface_token

      type associativity = Cmly_format.token_associativity =
        | LeftAssoc
        | RightAssoc
        | NonAssoc
        | UndefinedAssoc

      let ocamltype     t = t.tk_ocamltype
      let position      t = t.tk_position
      let alias         t = t.tk_alias
      let attributes    t = t.tk_attributes
      let associativity t = t.tk_associativity
      let precedence    t = t.tk_precedence
      let is_declared   t = t.tk_is_declared
    end

    module Syntax = struct
      type ('param, 'sym) t = ('param, 'sym) surface_syntax
      let types  t = t.s_types
      let tokens t = t.s_tokens
      let rules  t = t.s_rules
      type ground = (unit, name) t
      type higher = (name list, Parameter.t) t
    end

    let start_symbols    = grammar.g_start_symbols
    let on_error_reduce  = grammar.g_on_error_reduce
    let before_expansion = grammar.g_before_expansion
    let before_inlining  = grammar.g_before_inlining
  end

  module Grammar = struct
    let basename     = grammar.g_basename
    let preludes     = grammar.g_preludes
    let postludes    = grammar.g_postludes
    let entry_points = grammar.g_entry_points
    let attributes   = grammar.g_attributes
    let parameters   = grammar.g_parameters
  end

  module Terminal = struct
    let table = grammar.g_terminals
    let name       i = table.(i).t_name
    let kind       i = table.(i).t_kind
    let typ        i = table.(i).t_type
    let attributes i = table.(i).t_attributes
    include Index(struct
      let name = "Terminal"
      let count = Array.length table
    end)
  end

  module Nonterminal = struct
    let table = grammar.g_nonterminals
    let name         i = table.(i).n_name
    let mangled_name i = table.(i).n_mangled_name
    let kind         i = table.(i).n_kind
    let typ          i = table.(i).n_type
    let positions    i = table.(i).n_positions
    let nullable     i = table.(i).n_nullable
    let first        i = table.(i).n_first
    let attributes   i = table.(i).n_attributes
    include Index(struct
      let name = "Nonterminal"
      let count = Array.length table
    end)
  end

  type symbol = Cmly_format.symbol =
    | T of terminal
    | N of nonterminal

  let symbol_name ?(mangled=false) = function
    | T t ->
        Terminal.name t
    | N n ->
        if mangled then Nonterminal.mangled_name n
        else Nonterminal.name n

  module Symbol = struct

    type t = symbol =
      | T of terminal
      | N of nonterminal

    let hash = function T t -> t | N nt -> nt (* [t] and [nt] are integers *)
    let equal = (=) (* OK to use polymorphic equality *)
    let compare = compare (* OK to use polymorphic comparison *)

    let name = symbol_name

  end

  module Production = struct
    let table = grammar.g_productions
    let kind       i = table.(i).p_kind
    let lhs        i = table.(i).p_lhs
    let rhs        i = table.(i).p_rhs
    let positions  i = table.(i).p_positions
    let action     i = table.(i).p_action
    let attributes i = table.(i).p_attributes
    include Index(struct
      let name = "Production"
      let count = Array.length table
    end)
  end

  module Lr0 = struct
    let table = grammar.g_lr0_states
    let incoming i = table.(i).lr0_incoming
    let items    i = table.(i).lr0_items
    include Index(struct
      let name = "Lr0"
      let count = Array.length table
    end)
  end

  module Lr1 = struct
    let table = grammar.g_lr1_states
    let lr0         i = table.(i).lr1_lr0
    let transitions i = table.(i).lr1_transitions
    let get_reductions i = table.(i).lr1_reductions
    let default_reduction i = table.(i).lr1_default_reduction
    include Index(struct
      let name = "Lr1"
      let count = Array.length table
    end)
    let reductions i =
      List.map (fun (s, p) -> (s, [p]))
        table.(i).lr1_reductions
  end

  module Print = struct

    let terminal ppf t =
      Format.pp_print_string ppf (Terminal.name t)

    let nonterminal ppf t =
      Format.pp_print_string ppf (Nonterminal.name t)

    let symbol ppf = function
      | T t -> terminal ppf t
      | N n -> nonterminal ppf n

    let mangled_nonterminal ppf t =
      Format.pp_print_string ppf (Nonterminal.name t)

    let mangled_symbol ppf = function
      | T t -> terminal ppf t
      | N n -> mangled_nonterminal ppf n

    let rec lengths l acc = function
      | [] ->
          if l = -1 then []
          else l :: lengths (-1) [] acc
      | [] :: rows ->
          lengths l acc rows
      | (col :: cols) :: rows ->
          lengths (max l (String.length col)) (cols :: acc) rows

    let rec adjust_length lengths cols =
      match lengths, cols with
      | l :: ls, c :: cs ->
          let pad = l - String.length c in
          let c =
            if pad = 0 then c
            else c ^ String.make pad ' '
          in
          c :: adjust_length ls cs
      | _, [] -> []
      | [], _ -> assert false

    let align_tabular rows =
      let lengths = lengths (-1) [] rows in
      List.map (adjust_length lengths) rows

    let print_line ppf = function
      | [] -> ()
      | x :: xs ->
          Format.fprintf ppf "%s" x;
          List.iter (Format.fprintf ppf " %s") xs

    let print_table ppf table =
      let table = align_tabular table in
      List.iter (Format.fprintf ppf "%a\n" print_line) table

    let annot_itemset annots ppf items =
      let last_lhs = ref (-1) in
      let prepare (p, pos) annot =
        let rhs =
          Array.map (fun (sym, id, _) ->
            if id <> "" && id.[0] <> '_' then
              "(" ^ id ^ " = " ^ symbol_name sym ^ ")"
            else symbol_name sym
          ) (Production.rhs p)
        in
        if pos >= 0 && pos < Array.length rhs then
          rhs.(pos) <- ". " ^ rhs.(pos)
        else if pos > 0 && pos = Array.length rhs then
          rhs.(pos - 1) <- rhs.(pos - 1) ^ " .";
        let lhs = Production.lhs p in
        let rhs = Array.to_list rhs in
        let rhs =
          if !last_lhs = lhs then
            "" :: "  |" :: rhs
          else begin
            last_lhs := lhs;
            Nonterminal.name lhs :: "::=" :: rhs
          end
        in
        if annot = [] then
          [rhs]
        else
          [rhs; ("" :: "" :: annot)]
      in
      let rec prepare_all xs ys =
        match xs, ys with
        | [], _ ->
            []
        | (x :: xs), (y :: ys) ->
            let z = prepare x y in
            z :: prepare_all xs ys
        | (x :: xs), [] ->
            let z = prepare x [] in
            z :: prepare_all xs []
      in
      print_table ppf (List.concat (prepare_all items annots))

    let itemset ppf t =
      annot_itemset [] ppf t

    let annot_item annot ppf item =
      annot_itemset [annot] ppf [item]

    let item ppf t =
      annot_item [] ppf t

    let production ppf t =
      item ppf (t, -1)

  end

end

(* ------------------------------------------------------------------------ *)

(* High-level views of the low-level functions [read] and [from_string]. *)

module Read (X : sig val filename : string end) =
  Lift (struct let grammar = read X.filename end)

module FromString (X : sig val content : string end) =
  Lift (struct let grammar = from_string X.content end)