path: root/parsing/egrammar.ml

(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(* $Id$ *)

open Pp
open Util
open Extend
open Pcoq
open Coqast
open Ast
open Genarg

(* State of the grammar extensions *)

type all_grammar_command =
  | AstGrammar of grammar_command
  | TacticGrammar of
      (string * (string * grammar_production list) * Tacexpr.raw_tactic_expr)
      list

let subst_all_grammar_command subst = function
  | AstGrammar gc -> AstGrammar (subst_grammar_command subst gc)
  | TacticGrammar g -> TacticGrammar g (* TODO ... *)

let (grammar_state : all_grammar_command list ref) = ref []

(* Interpretation of the right hand side of grammar rules *)

(* When reporting errors, we add the name of the grammar rule that failed *)
let specify_name name e =
  match e with
    | UserError(lab,strm) ->
        UserError(lab, (str"during interpretation of grammar rule " ++
                          str name ++ str"," ++ spc () ++ strm))
    | Anomaly(lab,strm) ->
        Anomaly(lab, (str"during interpretation of grammar rule " ++
                        str name ++ str"," ++ spc () ++ strm))
    | Failure s ->
        Failure("during interpretation of grammar rule "^name^", "^s)
    | e -> e

let gram_action (name, etyp) env act dloc =
  try
    let v = Ast.eval_act dloc env act in
    match etyp, v with
      | (PureAstType, PureAstNode ast) -> Obj.repr ast
      | (AstListType, AstListNode astl) -> Obj.repr astl
      | (GenAstType ConstrArgType, PureAstNode ast) -> Obj.repr ast
      | _ -> grammar_type_error (dloc, "Egrammar.gram_action")
  with e ->
    let (loc, exn) =
      match e with
        | Stdpp.Exc_located (loce, lexn) -> (loce, lexn)
        | e -> (dloc, e)
    in
    Stdpp.raise_with_loc loc (specify_name name exn)

(* Translation of environments: a production
 *   [ nt1($x1) ... nti($xi) ] -> act($x1..$xi)
 * is written (with camlp4 conventions):
 *   (fun vi -> .... (fun v1 -> act(v1 .. vi) )..)
 * where v1..vi are the values generated by non-terminals nt1..nti.
 * Since the actions are executed by substituting an environment,
 * make_act builds the following closure:
 *
 *      ((fun env ->
 *          (fun vi -> 
 *             (fun env -> ...
 *           
 *                  (fun v1 ->
 *                     (fun env -> gram_action .. env act)
 *                     (($x1,v1)::env))
 *                  ...)
 *             (($xi,vi)::env)))
 *         [])
 *)

let make_act name_typ a pil =
  let act_without_arg env = Gramext.action (gram_action name_typ env a)
  and make_prod_item act_tl = function
    | None -> (* parse a non-binding item *)
        (fun env -> Gramext.action (fun _ -> act_tl env))
    | Some (p, ETast) -> (* non-terminal *)
        (fun env -> Gramext.action (fun v -> act_tl((p,PureAstNode v)::env)))
    | Some (p, ETastl) -> (* non-terminal *)
        (fun env -> Gramext.action (fun v -> act_tl((p,AstListNode v)::env)))
  in 
  (List.fold_left make_prod_item act_without_arg pil) []

(* Grammar extension command. Rules are assumed correct.
 * Type-checking of grammar rules is done during the translation of
 * ast to the type grammar_command.  We only check that the existing
 * entries have the type assumed in the grammar command (these types
 * annotations are added when type-checking the command, function
 * Extend.of_ast) *)

let get_entry_type (u,n) =
  Gram.Entry.obj (object_of_typed_entry (get_entry (get_univ u) n))

let rec build_prod_item univ = function
  | ProdList0 s -> Gramext.Slist0 (build_prod_item univ s)
  | ProdList1 s -> Gramext.Slist1 (build_prod_item univ s)
  | ProdOpt s   -> Gramext.Sopt   (build_prod_item univ s)
  | ProdPrimitive nt -> 
      let eobj = get_entry_type nt in
      Gramext.Snterm eobj

let symbol_of_prod_item univ = function
  | Term tok -> (Gramext.Stoken tok, None)
  | NonTerm (nt, ovar) ->
      let eobj = build_prod_item univ nt in
      (eobj, ovar)

let make_rule univ etyp rule =
  let pil = List.map (symbol_of_prod_item univ) rule.gr_production in
  let (symbs,ntl) = List.split pil in
  let act = make_act (rule.gr_name,etyp) rule.gr_action ntl in
  (symbs, act)

(* Rules of a level are entered in reverse order, so that the first rules
   are applied before the last ones *)
let extend_entry univ (te, etyp, ass, rls) =
  let rules = List.rev (List.map (make_rule univ etyp) rls) in
  grammar_extend te None [(None, ass, rules)]

(* Defines new entries. If the entry already exists, check its type *)
let define_entry univ {ge_name=n; ge_type=typ; gl_assoc=ass; gl_rules=rls} =
  let typ = if typ = ETast then GenAstType ConstrArgType else AstListType in
  let e = force_entry_type univ n typ in
  (e,typ,ass,rls)

(* Add a bunch of grammar rules. Does not check if it is well formed *)
let extend_grammar gram =
  let univ = get_univ gram.gc_univ in
  let tl = List.map (define_entry univ) gram.gc_entries in
  List.iter (extend_entry univ) tl

(* Add a grammar rules for tactics *)
type grammar_tactic_production =
  | TacTerm of string
  | TacNonTerm of loc * (Gramext.g_symbol * argument_type) * string option

let make_prod_item = function
  | TacTerm s -> (Gramext.Stoken (Extend.terminal s), None)
  | TacNonTerm (_,(nont,t), po) ->
      (nont, option_app (fun p -> (p,t)) po)

let make_gen_act f pil =
  let rec make env = function
    | [] -> 
	Gramext.action (fun loc -> f env)
    | None :: tl -> (* parse a non-binding item *)
        Gramext.action (fun _ -> make env tl)
    | Some (p, t) :: tl -> (* non-terminal *)
        Gramext.action (fun v -> make ((p,in_generic t v) :: env) tl) in
  make [] (List.rev pil)

let make_rule univ f g (s',pt) =
  let hd = Gramext.Stoken ("IDENT", s') in
  let pil = (hd,None) :: List.map g pt in
  let (symbs,ntl) = List.split pil in
  let act = make_gen_act f ntl in
  (symbs, act)

(* These grammars are not a removable *)
let extend_tactic_grammar s gl =
  let univ = get_univ "tactic" in
  let make_act l = Tacexpr.TacExtend (s,List.map snd l) in
  let rules = List.rev (List.map (make_rule univ make_act make_prod_item) gl)
  in Gram.extend Tactic.simple_tactic None [(None, None, rules)]

let extend_vernac_command_grammar s gl =
  let univ = get_univ "vernac" in
  let make_act l = Vernacexpr.VernacExtend (s,List.map snd l) in
  let rules = List.rev (List.map (make_rule univ make_act make_prod_item) gl)
  in Gram.extend Vernac_.command None [(None, None, rules)]

let rec interp_entry_name u s =
  let l = String.length s in
  if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then
    let t, g = interp_entry_name u (String.sub s 3 (l-8)) in
    List1ArgType t, Gramext.Slist1 g
  else if l > 5 & String.sub s (l-5) 5 = "_list" then
    let t, g = interp_entry_name u (String.sub s 0 (l-5)) in
    List0ArgType t, Gramext.Slist0 g
  else if l > 4 & String.sub s (l-4) 4 = "_opt" then
    let t, g = interp_entry_name u (String.sub s 0 (l-4)) in
    OptArgType t, Gramext.Sopt g
  else
    let n = Extend.rename_command s in
    let e = get_entry (get_univ u) n in
    let o = object_of_typed_entry e in
    let t = match type_of_typed_entry e with
      | GenAstType t -> t
      | _ -> failwith "Only entries of generic type can be used in alias" in
    t, Gramext.Snterm (Pcoq.Gram.Entry.obj o)

let qualified_nterm current_univ = function
  | NtQual (univ, en) -> (rename_command univ, rename_command en)
  | NtShort en -> (current_univ, rename_command en)

let make_vprod_item univ = function
  | VTerm s -> (Gramext.Stoken (Extend.terminal s), None)
  | VNonTerm (loc, nt, po) ->
      let (u,nt) = qualified_nterm univ nt in
      let (etyp, e) = interp_entry_name u nt in
      e, option_app (fun p -> (p,etyp)) po

let add_tactic_entries gl =
  let univ = get_univ "tactic" in
  let make_act s tac l = Tacexpr.TacAlias (s,l,tac) in
  let rules = 
    List.rev (List.map (fun (s,l,tac) -> make_rule univ (make_act s tac) (make_vprod_item "tactic") l) gl)
  in
  let tacentry = get_entry (get_univ "tactic") "simple_tactic" in
  grammar_extend tacentry None [(None, None, rules)]

let extend_grammar gram =
  (match gram with
  | AstGrammar g -> extend_grammar g
  | TacticGrammar l -> add_tactic_entries l);
  grammar_state := gram :: !grammar_state


(* Summary functions: the state of the lexer is included in that of the parser.
   Because the grammar affects the set of keywords when adding or removing
   grammar rules. *)
type frozen_t = all_grammar_command list * Lexer.frozen_t

let freeze () = (!grammar_state, Lexer.freeze ())

(* We compare the current state of the grammar and the state to unfreeze, 
   by computing the longest common suffixes *)
let factorize_grams l1 l2 =
  if l1 == l2 then ([], [], l1) else list_share_tails l1 l2

let number_of_entries gcl =
  List.fold_left
    (fun n -> function
      | AstGrammar gc -> n + (List.length gc.gc_entries)
      | TacticGrammar l -> n + 1)
    0 gcl

let unfreeze (grams, lex) =
  let (undo, redo, common) = factorize_grams !grammar_state grams in
  remove_grammars (number_of_entries undo);
  grammar_state := common;
  Lexer.unfreeze lex;
  List.iter extend_grammar (List.rev redo)
    
let init_grammar () =
  remove_grammars (number_of_entries !grammar_state);
  grammar_state := []

let _ = Lexer.init ()

let init () =
  init_grammar ()