--- /dev/null
+requires="helm-cic_acic"
+version="0.0.1"
+archive(byte)="acic_content.cma"
+archive(native)="acic_content.cmxa"
--- /dev/null
+requires="helm-cic_proof_checking"
+version="0.0.1"
+archive(byte)="cic_acic.cma"
+archive(native)="cic_acic.cmxa"
-requires="helm-whelp helm-cic_notation helm-cic_unification"
+requires="helm-whelp helm-content_pres helm-cic_unification"
version="0.0.1"
archive(byte)="cic_disambiguation.cma"
archive(native)="cic_disambiguation.cmxa"
+++ /dev/null
-requires="helm-cic helm-utf8_macros camlp4.gramlib helm-cic_proof_checking ulex"
-version="0.0.1"
-archive(byte)="cic_notation.cma"
-archive(native)="cic_notation.cmxa"
+++ /dev/null
-requires="helm-cic_proof_checking"
-version="0.0.1"
-archive(byte)="cic_omdoc.cma"
-archive(native)="cic_omdoc.cmxa"
+++ /dev/null
-requires="helm-utf8_macros helm-xml helm-cic_proof_checking helm-cic_omdoc helm-registry helm-cic_notation gdome2"
-version="0.0.1"
-archive(byte)="cic_transformations.cma"
-archive(native)="cic_transformations.cmxa"
-linkopts=""
--- /dev/null
+requires="helm-acic_content helm-utf8_macros camlp4.gramlib ulex"
+version="0.0.1"
+archive(byte)="content_pres.cma"
+archive(native)="content_pres.cmxa"
--- /dev/null
+requires="helm-content_pres"
+version="0.0.1"
+archive(byte)="grafite.cma"
+archive(native)="grafite.cmxa"
--- /dev/null
+requires="helm-xml gdome2"
+version="0.0.1"
+archive(byte)="hgdome.cma"
+archive(native)="hgdome.cmxa"
MODULES = \
extlib \
xml \
+ hgdome \
registry \
hmysql \
utf8_macros \
cic \
cic_proof_checking \
cic_unification \
- cic_omdoc \
+ cic_acic \
+ acic_content \
+ content_pres \
+ grafite \
metadata \
whelp \
tactics \
- cic_notation \
- cic_transformations \
cic_disambiguation \
paramodulation \
$(NULL)
--- /dev/null
+*.cm[iaox]
+*.cmxa
--- /dev/null
+contentPp.cmi: content.cmi
+acic2content.cmi: content.cmi
+content2cic.cmi: content.cmi
+cicNotationUtil.cmi: cicNotationPt.cmo
+cicNotationEnv.cmi: cicNotationPt.cmo
+cicNotationPp.cmi: cicNotationPt.cmo cicNotationEnv.cmi
+acic2astMatcher.cmi: cicNotationPt.cmo
+termAcicContent.cmi: cicNotationPt.cmo
+content.cmo: content.cmi
+content.cmx: content.cmi
+contentPp.cmo: content.cmi contentPp.cmi
+contentPp.cmx: content.cmx contentPp.cmi
+acic2content.cmo: content.cmi acic2content.cmi
+acic2content.cmx: content.cmx acic2content.cmi
+content2cic.cmo: content.cmi content2cic.cmi
+content2cic.cmx: content.cmx content2cic.cmi
+cicNotationUtil.cmo: cicNotationPt.cmo cicNotationUtil.cmi
+cicNotationUtil.cmx: cicNotationPt.cmx cicNotationUtil.cmi
+cicNotationEnv.cmo: cicNotationUtil.cmi cicNotationPt.cmo cicNotationEnv.cmi
+cicNotationEnv.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationEnv.cmi
+cicNotationPp.cmo: cicNotationPt.cmo cicNotationEnv.cmi cicNotationPp.cmi
+cicNotationPp.cmx: cicNotationPt.cmx cicNotationEnv.cmx cicNotationPp.cmi
+acic2astMatcher.cmo: cicNotationUtil.cmi cicNotationPt.cmo cicNotationPp.cmi \
+ acic2astMatcher.cmi
+acic2astMatcher.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationPp.cmx \
+ acic2astMatcher.cmi
+termAcicContent.cmo: cicNotationUtil.cmi cicNotationPt.cmo cicNotationPp.cmi \
+ acic2astMatcher.cmi termAcicContent.cmi
+termAcicContent.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationPp.cmx \
+ acic2astMatcher.cmx termAcicContent.cmi
--- /dev/null
+PACKAGE = acic_content
+PREDICATES =
+
+INTERFACE_FILES = \
+ content.mli \
+ contentPp.mli \
+ acic2content.mli \
+ content2cic.mli \
+ cicNotationUtil.mli \
+ cicNotationEnv.mli \
+ cicNotationPp.mli \
+ acic2astMatcher.mli \
+ termAcicContent.mli \
+ $(NULL)
+IMPLEMENTATION_FILES = \
+ cicNotationPt.ml \
+ $(INTERFACE_FILES:%.mli=%.ml)
+
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+module Ast = CicNotationPt
+module Util = CicNotationUtil
+
+module Matcher32 =
+struct
+ module Pattern32 =
+ struct
+ type cic_mask_t =
+ Blob
+ | Uri of UriManager.uri
+ | Appl of cic_mask_t list
+
+ let uri_of_term t = CicUtil.uri_of_term (Deannotate.deannotate_term t)
+
+ let mask_of_cic = function
+ | Cic.AAppl (_, tl) -> Appl (List.map (fun _ -> Blob) tl), tl
+ | Cic.AConst (_, _, [])
+ | Cic.AVar (_, _, [])
+ | Cic.AMutInd (_, _, _, [])
+ | Cic.AMutConstruct (_, _, _, _, []) as t -> Uri (uri_of_term t), []
+ | _ -> Blob, []
+
+ let tag_of_term t =
+ let mask, tl = mask_of_cic t in
+ Hashtbl.hash mask, tl
+
+ let mask_of_appl_pattern = function
+ | Ast.UriPattern uri -> Uri uri, []
+ | Ast.ImplicitPattern
+ | Ast.VarPattern _ -> Blob, []
+ | Ast.ApplPattern pl -> Appl (List.map (fun _ -> Blob) pl), pl
+
+ let tag_of_pattern p =
+ let mask, pl = mask_of_appl_pattern p in
+ Hashtbl.hash mask, pl
+
+ type pattern_t = Ast.cic_appl_pattern
+ type term_t = Cic.annterm
+
+ let string_of_pattern = CicNotationPp.pp_cic_appl_pattern
+ let string_of_term t = CicPp.ppterm (Deannotate.deannotate_term t)
+
+ let classify = function
+ | Ast.ImplicitPattern
+ | Ast.VarPattern _ -> PatternMatcher.Variable
+ | Ast.UriPattern _
+ | Ast.ApplPattern _ -> PatternMatcher.Constructor
+ end
+
+ module M = PatternMatcher.Matcher (Pattern32)
+
+ let compiler rows =
+ let match_cb rows =
+ let pl, pid = try List.hd rows with Not_found -> assert false in
+ (fun matched_terms constructors ->
+ let env =
+ try
+ List.map2
+ (fun p t ->
+ match p with
+ | Ast.ImplicitPattern -> Util.fresh_name (), t
+ | Ast.VarPattern name -> name, t
+ | _ -> assert false)
+ pl matched_terms
+ with Invalid_argument _ -> assert false
+ in
+ Some (env, constructors, pid))
+ in
+ M.compiler rows match_cb (fun () -> None)
+end
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+module Matcher32:
+sig
+ (** @param l3_patterns level 3 (CIC) patterns (AKA cic_appl_pattern) *)
+ val compiler :
+ (CicNotationPt.cic_appl_pattern * int) list ->
+ (Cic.annterm ->
+ ((string * Cic.annterm) list * Cic.annterm list * int) option)
+end
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(**************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Andrea Asperti <asperti@cs.unibo.it> *)
+(* 16/6/2003 *)
+(* *)
+(**************************************************************************)
+
+let object_prefix = "obj:";;
+let declaration_prefix = "decl:";;
+let definition_prefix = "def:";;
+let inductive_prefix = "ind:";;
+let joint_prefix = "joint:";;
+let proof_prefix = "proof:";;
+let conclude_prefix = "concl:";;
+let premise_prefix = "prem:";;
+let lemma_prefix = "lemma:";;
+
+(* e se mettessi la conversione di BY nell'apply_context ? *)
+(* sarebbe carino avere l'invariante che la proof2pres
+generasse sempre prove con contesto vuoto *)
+
+let gen_id prefix seed =
+ let res = prefix ^ string_of_int !seed in
+ incr seed ;
+ res
+;;
+
+let name_of = function
+ Cic.Anonymous -> None
+ | Cic.Name b -> Some b;;
+
+exception Not_a_proof;;
+exception NotImplemented;;
+exception NotApplicable;;
+
+(* we do not care for positivity, here, that in any case is enforced by
+ well typing. Just a brutal search *)
+
+let rec occur uri =
+ let module C = Cic in
+ function
+ C.Rel _ -> false
+ | C.Var _ -> false
+ | C.Meta _ -> false
+ | C.Sort _ -> false
+ | C.Implicit _ -> assert false
+ | C.Prod (_,s,t) -> (occur uri s) or (occur uri t)
+ | C.Cast (te,ty) -> (occur uri te)
+ | C.Lambda (_,s,t) -> (occur uri s) or (occur uri t) (* or false ?? *)
+ | C.LetIn (_,s,t) -> (occur uri s) or (occur uri t)
+ | C.Appl l ->
+ List.fold_left
+ (fun b a ->
+ if b then b
+ else (occur uri a)) false l
+ | C.Const (_,_) -> false
+ | C.MutInd (uri1,_,_) -> if uri = uri1 then true else false
+ | C.MutConstruct (_,_,_,_) -> false
+ | C.MutCase _ -> false (* presuming too much?? *)
+ | C.Fix _ -> false (* presuming too much?? *)
+ | C.CoFix (_,_) -> false (* presuming too much?? *)
+;;
+
+let get_id =
+ let module C = Cic in
+ function
+ C.ARel (id,_,_,_) -> id
+ | C.AVar (id,_,_) -> id
+ | C.AMeta (id,_,_) -> id
+ | C.ASort (id,_) -> id
+ | C.AImplicit _ -> raise NotImplemented
+ | C.AProd (id,_,_,_) -> id
+ | C.ACast (id,_,_) -> id
+ | C.ALambda (id,_,_,_) -> id
+ | C.ALetIn (id,_,_,_) -> id
+ | C.AAppl (id,_) -> id
+ | C.AConst (id,_,_) -> id
+ | C.AMutInd (id,_,_,_) -> id
+ | C.AMutConstruct (id,_,_,_,_) -> id
+ | C.AMutCase (id,_,_,_,_,_) -> id
+ | C.AFix (id,_,_) -> id
+ | C.ACoFix (id,_,_) -> id
+;;
+
+let test_for_lifting ~ids_to_inner_types ~ids_to_inner_sorts=
+ let module C = Cic in
+ let module C2A = Cic2acic in
+ (* atomic terms are never lifted, according to my policy *)
+ function
+ C.ARel (id,_,_,_) -> false
+ | C.AVar (id,_,_) ->
+ (try
+ ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
+ true;
+ with Not_found -> false)
+ | C.AMeta (id,_,_) ->
+ (try
+ Hashtbl.find ids_to_inner_sorts id = `Prop
+ with Not_found -> assert false)
+ | C.ASort (id,_) -> false
+ | C.AImplicit _ -> raise NotImplemented
+ | C.AProd (id,_,_,_) -> false
+ | C.ACast (id,_,_) ->
+ (try
+ ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
+ true;
+ with Not_found -> false)
+ | C.ALambda (id,_,_,_) ->
+ (try
+ ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
+ true;
+ with Not_found -> false)
+ | C.ALetIn (id,_,_,_) ->
+ (try
+ ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
+ true;
+ with Not_found -> false)
+ | C.AAppl (id,_) ->
+ (try
+ ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
+ true;
+ with Not_found -> false)
+ | C.AConst (id,_,_) ->
+ (try
+ ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
+ true;
+ with Not_found -> false)
+ | C.AMutInd (id,_,_,_) -> false
+ | C.AMutConstruct (id,_,_,_,_) ->
+ (try
+ ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
+ true;
+ with Not_found -> false)
+ (* oppure: false *)
+ | C.AMutCase (id,_,_,_,_,_) ->
+ (try
+ ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
+ true;
+ with Not_found -> false)
+ | C.AFix (id,_,_) ->
+ (try
+ ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
+ true;
+ with Not_found -> false)
+ | C.ACoFix (id,_,_) ->
+ (try
+ ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
+ true;
+ with Not_found -> false)
+;;
+
+(* transform a proof p into a proof list, concatenating the last
+conclude element to the apply_context list, in case context is
+empty. Otherwise, it just returns [p] *)
+
+let flat seed p =
+ let module K = Content in
+ if (p.K.proof_context = []) then
+ if p.K.proof_apply_context = [] then [p]
+ else
+ let p1 =
+ { p with
+ K.proof_context = [];
+ K.proof_apply_context = []
+ } in
+ p.K.proof_apply_context@[p1]
+ else
+ [p]
+;;
+
+let rec serialize seed =
+ function
+ [] -> []
+ | a::l -> (flat seed a)@(serialize seed l)
+;;
+
+(* top_down = true if the term is a LAMBDA or a decl *)
+let generate_conversion seed top_down id inner_proof ~ids_to_inner_types =
+ let module C2A = Cic2acic in
+ let module K = Content in
+ let exp = (try ((Hashtbl.find ids_to_inner_types id).C2A.annexpected)
+ with Not_found -> None)
+ in
+ match exp with
+ None -> inner_proof
+ | Some expty ->
+ if inner_proof.K.proof_conclude.K.conclude_method = "Intros+LetTac" then
+ { K.proof_name = inner_proof.K.proof_name;
+ K.proof_id = gen_id proof_prefix seed;
+ K.proof_context = [] ;
+ K.proof_apply_context = [];
+ K.proof_conclude =
+ { K.conclude_id = gen_id conclude_prefix seed;
+ K.conclude_aref = id;
+ K.conclude_method = "TD_Conversion";
+ K.conclude_args =
+ [K.ArgProof {inner_proof with K.proof_name = None}];
+ K.conclude_conclusion = Some expty
+ };
+ }
+ else
+ { K.proof_name = inner_proof.K.proof_name;
+ K.proof_id = gen_id proof_prefix seed;
+ K.proof_context = [] ;
+ K.proof_apply_context = [{inner_proof with K.proof_name = None}];
+ K.proof_conclude =
+ { K.conclude_id = gen_id conclude_prefix seed;
+ K.conclude_aref = id;
+ K.conclude_method = "BU_Conversion";
+ K.conclude_args =
+ [K.Premise
+ { K.premise_id = gen_id premise_prefix seed;
+ K.premise_xref = inner_proof.K.proof_id;
+ K.premise_binder = None;
+ K.premise_n = None
+ }
+ ];
+ K.conclude_conclusion = Some expty
+ };
+ }
+;;
+
+let generate_exact seed t id name ~ids_to_inner_types =
+ let module C2A = Cic2acic in
+ let module K = Content in
+ { K.proof_name = name;
+ K.proof_id = gen_id proof_prefix seed ;
+ K.proof_context = [] ;
+ K.proof_apply_context = [];
+ K.proof_conclude =
+ { K.conclude_id = gen_id conclude_prefix seed;
+ K.conclude_aref = id;
+ K.conclude_method = "Exact";
+ K.conclude_args = [K.Term t];
+ K.conclude_conclusion =
+ try Some (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
+ with Not_found -> None
+ };
+ }
+;;
+
+let generate_intros_let_tac seed id n s is_intro inner_proof name ~ids_to_inner_types =
+ let module C2A = Cic2acic in
+ let module C = Cic in
+ let module K = Content in
+ { K.proof_name = name;
+ K.proof_id = gen_id proof_prefix seed ;
+ K.proof_context = [] ;
+ K.proof_apply_context = [];
+ K.proof_conclude =
+ { K.conclude_id = gen_id conclude_prefix seed;
+ K.conclude_aref = id;
+ K.conclude_method = "Intros+LetTac";
+ K.conclude_args = [K.ArgProof inner_proof];
+ K.conclude_conclusion =
+ try Some
+ (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
+ with Not_found ->
+ (match inner_proof.K.proof_conclude.K.conclude_conclusion with
+ None -> None
+ | Some t ->
+ if is_intro then Some (C.AProd ("gen"^id,n,s,t))
+ else Some (C.ALetIn ("gen"^id,n,s,t)))
+ };
+ }
+;;
+
+let build_decl_item seed id n s ~ids_to_inner_sorts =
+ let module K = Content in
+ let sort =
+ try
+ Some (Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id))
+ with Not_found -> None
+ in
+ match sort with
+ | Some `Prop ->
+ `Hypothesis
+ { K.dec_name = name_of n;
+ K.dec_id = gen_id declaration_prefix seed;
+ K.dec_inductive = false;
+ K.dec_aref = id;
+ K.dec_type = s
+ }
+ | _ ->
+ `Declaration
+ { K.dec_name = name_of n;
+ K.dec_id = gen_id declaration_prefix seed;
+ K.dec_inductive = false;
+ K.dec_aref = id;
+ K.dec_type = s
+ }
+;;
+
+let rec build_subproofs_and_args seed l ~ids_to_inner_types ~ids_to_inner_sorts =
+ let module C = Cic in
+ let module K = Content in
+ let rec aux =
+ function
+ [] -> [],[]
+ | t::l1 ->
+ let subproofs,args = aux l1 in
+ if (test_for_lifting t ~ids_to_inner_types ~ids_to_inner_sorts) then
+ let new_subproof =
+ acic2content
+ seed ~name:"H" ~ids_to_inner_types ~ids_to_inner_sorts t in
+ let new_arg =
+ K.Premise
+ { K.premise_id = gen_id premise_prefix seed;
+ K.premise_xref = new_subproof.K.proof_id;
+ K.premise_binder = new_subproof.K.proof_name;
+ K.premise_n = None
+ } in
+ new_subproof::subproofs,new_arg::args
+ else
+ let hd =
+ (match t with
+ C.ARel (idr,idref,n,b) ->
+ let sort =
+ (try
+ Hashtbl.find ids_to_inner_sorts idr
+ with Not_found -> `Type (CicUniv.fresh())) in
+ if sort = `Prop then
+ K.Premise
+ { K.premise_id = gen_id premise_prefix seed;
+ K.premise_xref = idr;
+ K.premise_binder = Some b;
+ K.premise_n = Some n
+ }
+ else (K.Term t)
+ | C.AConst(id,uri,[]) ->
+ let sort =
+ (try
+ Hashtbl.find ids_to_inner_sorts id
+ with Not_found -> `Type (CicUniv.fresh())) in
+ if sort = `Prop then
+ K.Lemma
+ { K.lemma_id = gen_id lemma_prefix seed;
+ K.lemma_name = UriManager.name_of_uri uri;
+ K.lemma_uri = UriManager.string_of_uri uri
+ }
+ else (K.Term t)
+ | C.AMutConstruct(id,uri,tyno,consno,[]) ->
+ let sort =
+ (try
+ Hashtbl.find ids_to_inner_sorts id
+ with Not_found -> `Type (CicUniv.fresh())) in
+ if sort = `Prop then
+ let inductive_types =
+ (let o,_ =
+ CicEnvironment.get_obj CicUniv.empty_ugraph uri
+ in
+ match o with
+ | Cic.InductiveDefinition (l,_,_,_) -> l
+ | _ -> assert false
+ ) in
+ let (_,_,_,constructors) =
+ List.nth inductive_types tyno in
+ let name,_ = List.nth constructors (consno - 1) in
+ K.Lemma
+ { K.lemma_id = gen_id lemma_prefix seed;
+ K.lemma_name = name;
+ K.lemma_uri =
+ UriManager.string_of_uri uri ^ "#xpointer(1/" ^
+ string_of_int (tyno+1) ^ "/" ^ string_of_int consno ^
+ ")"
+ }
+ else (K.Term t)
+ | _ -> (K.Term t)) in
+ subproofs,hd::args
+ in
+ match (aux l) with
+ [p],args ->
+ [{p with K.proof_name = None}],
+ List.map
+ (function
+ K.Premise prem when prem.K.premise_xref = p.K.proof_id ->
+ K.Premise {prem with K.premise_binder = None}
+ | i -> i) args
+ | p,a as c -> c
+
+and
+
+build_def_item seed id n t ~ids_to_inner_sorts ~ids_to_inner_types =
+ let module K = Content in
+ try
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ if sort = `Prop then
+ (let p =
+ (acic2content seed ?name:(name_of n) ~ids_to_inner_sorts ~ids_to_inner_types t)
+ in
+ `Proof p;)
+ else
+ `Definition
+ { K.def_name = name_of n;
+ K.def_id = gen_id definition_prefix seed;
+ K.def_aref = id;
+ K.def_term = t
+ }
+ with
+ Not_found -> assert false
+
+(* the following function must be called with an object of sort
+Prop. For debugging purposes this is tested again, possibly raising an
+Not_a_proof exception *)
+
+and acic2content seed ?name ~ids_to_inner_sorts ~ids_to_inner_types t =
+ let rec aux ?name t =
+ let module C = Cic in
+ let module K = Content in
+ let module C2A = Cic2acic in
+ let t1 =
+ match t with
+ C.ARel (id,idref,n,b) as t ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ if sort = `Prop then
+ generate_exact seed t id name ~ids_to_inner_types
+ else raise Not_a_proof
+ | C.AVar (id,uri,exp_named_subst) as t ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ if sort = `Prop then
+ generate_exact seed t id name ~ids_to_inner_types
+ else raise Not_a_proof
+ | C.AMeta (id,n,l) as t ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ if sort = `Prop then
+ generate_exact seed t id name ~ids_to_inner_types
+ else raise Not_a_proof
+ | C.ASort (id,s) -> raise Not_a_proof
+ | C.AImplicit _ -> raise NotImplemented
+ | C.AProd (_,_,_,_) -> raise Not_a_proof
+ | C.ACast (id,v,t) -> aux v
+ | C.ALambda (id,n,s,t) ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ if sort = `Prop then
+ let proof = aux t in
+ let proof' =
+ if proof.K.proof_conclude.K.conclude_method = "Intros+LetTac" then
+ match proof.K.proof_conclude.K.conclude_args with
+ [K.ArgProof p] -> p
+ | _ -> assert false
+ else proof in
+ let proof'' =
+ { proof' with
+ K.proof_name = None;
+ K.proof_context =
+ (build_decl_item seed id n s ids_to_inner_sorts)::
+ proof'.K.proof_context
+ }
+ in
+ generate_intros_let_tac seed id n s true proof'' name ~ids_to_inner_types
+ else raise Not_a_proof
+ | C.ALetIn (id,n,s,t) ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ if sort = `Prop then
+ let proof = aux t in
+ let proof' =
+ if proof.K.proof_conclude.K.conclude_method = "Intros+LetTac" then
+ match proof.K.proof_conclude.K.conclude_args with
+ [K.ArgProof p] -> p
+ | _ -> assert false
+ else proof in
+ let proof'' =
+ { proof' with
+ K.proof_name = None;
+ K.proof_context =
+ ((build_def_item seed id n s ids_to_inner_sorts
+ ids_to_inner_types):> Cic.annterm K.in_proof_context_element)
+ ::proof'.K.proof_context;
+ }
+ in
+ generate_intros_let_tac seed id n s false proof'' name ~ids_to_inner_types
+ else raise Not_a_proof
+ | C.AAppl (id,li) ->
+ (try rewrite
+ seed name id li ~ids_to_inner_types ~ids_to_inner_sorts
+ with NotApplicable ->
+ try inductive
+ seed name id li ~ids_to_inner_types ~ids_to_inner_sorts
+ with NotApplicable ->
+ let subproofs, args =
+ build_subproofs_and_args
+ seed li ~ids_to_inner_types ~ids_to_inner_sorts in
+(*
+ let args_to_lift =
+ List.filter (test_for_lifting ~ids_to_inner_types) li in
+ let subproofs =
+ match args_to_lift with
+ [_] -> List.map aux args_to_lift
+ | _ -> List.map (aux ~name:"H") args_to_lift in
+ let args = build_args seed li subproofs
+ ~ids_to_inner_types ~ids_to_inner_sorts in *)
+ { K.proof_name = name;
+ K.proof_id = gen_id proof_prefix seed;
+ K.proof_context = [];
+ K.proof_apply_context = serialize seed subproofs;
+ K.proof_conclude =
+ { K.conclude_id = gen_id conclude_prefix seed;
+ K.conclude_aref = id;
+ K.conclude_method = "Apply";
+ K.conclude_args = args;
+ K.conclude_conclusion =
+ try Some
+ (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
+ with Not_found -> None
+ };
+ })
+ | C.AConst (id,uri,exp_named_subst) as t ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ if sort = `Prop then
+ generate_exact seed t id name ~ids_to_inner_types
+ else raise Not_a_proof
+ | C.AMutInd (id,uri,i,exp_named_subst) -> raise Not_a_proof
+ | C.AMutConstruct (id,uri,i,j,exp_named_subst) as t ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ if sort = `Prop then
+ generate_exact seed t id name ~ids_to_inner_types
+ else raise Not_a_proof
+ | C.AMutCase (id,uri,typeno,ty,te,patterns) ->
+ let inductive_types,noparams =
+ (let o, _ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ match o with
+ Cic.Constant _ -> assert false
+ | Cic.Variable _ -> assert false
+ | Cic.CurrentProof _ -> assert false
+ | Cic.InductiveDefinition (l,_,n,_) -> l,n
+ ) in
+ let (_,_,_,constructors) = List.nth inductive_types typeno in
+ let name_and_arities =
+ let rec count_prods =
+ function
+ C.Prod (_,_,t) -> 1 + count_prods t
+ | _ -> 0 in
+ List.map
+ (function (n,t) -> Some n,((count_prods t) - noparams)) constructors in
+ let pp =
+ let build_proof p (name,arity) =
+ let rec make_context_and_body c p n =
+ if n = 0 then c,(aux p)
+ else
+ (match p with
+ Cic.ALambda(idl,vname,s1,t1) ->
+ let ce =
+ build_decl_item seed idl vname s1 ~ids_to_inner_sorts in
+ make_context_and_body (ce::c) t1 (n-1)
+ | _ -> assert false) in
+ let context,body = make_context_and_body [] p arity in
+ K.ArgProof
+ {body with K.proof_name = name; K.proof_context=context} in
+ List.map2 build_proof patterns name_and_arities in
+ let teid = get_id te in
+ let context,term =
+ (match
+ build_subproofs_and_args
+ seed ~ids_to_inner_types ~ids_to_inner_sorts [te]
+ with
+ l,[t] -> l,t
+ | _ -> assert false) in
+ { K.proof_name = name;
+ K.proof_id = gen_id proof_prefix seed;
+ K.proof_context = [];
+ K.proof_apply_context = serialize seed context;
+ K.proof_conclude =
+ { K.conclude_id = gen_id conclude_prefix seed;
+ K.conclude_aref = id;
+ K.conclude_method = "Case";
+ K.conclude_args =
+ (K.Aux (UriManager.string_of_uri uri))::
+ (K.Aux (string_of_int typeno))::(K.Term ty)::term::pp;
+ K.conclude_conclusion =
+ try Some
+ (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
+ with Not_found -> None
+ }
+ }
+ | C.AFix (id, no, funs) ->
+ let proofs =
+ List.map
+ (function (_,name,_,_,bo) -> `Proof (aux ~name bo)) funs in
+ let fun_name =
+ List.nth (List.map (fun (_,name,_,_,_) -> name) funs) no
+ in
+ let decreasing_args =
+ List.map (function (_,_,n,_,_) -> n) funs in
+ let jo =
+ { K.joint_id = gen_id joint_prefix seed;
+ K.joint_kind = `Recursive decreasing_args;
+ K.joint_defs = proofs
+ }
+ in
+ { K.proof_name = name;
+ K.proof_id = gen_id proof_prefix seed;
+ K.proof_context = [`Joint jo];
+ K.proof_apply_context = [];
+ K.proof_conclude =
+ { K.conclude_id = gen_id conclude_prefix seed;
+ K.conclude_aref = id;
+ K.conclude_method = "Exact";
+ K.conclude_args =
+ [ K.Premise
+ { K.premise_id = gen_id premise_prefix seed;
+ K.premise_xref = jo.K.joint_id;
+ K.premise_binder = Some fun_name;
+ K.premise_n = Some no;
+ }
+ ];
+ K.conclude_conclusion =
+ try Some
+ (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
+ with Not_found -> None
+ }
+ }
+ | C.ACoFix (id,no,funs) ->
+ let proofs =
+ List.map
+ (function (_,name,_,bo) -> `Proof (aux ~name bo)) funs in
+ let jo =
+ { K.joint_id = gen_id joint_prefix seed;
+ K.joint_kind = `CoRecursive;
+ K.joint_defs = proofs
+ }
+ in
+ { K.proof_name = name;
+ K.proof_id = gen_id proof_prefix seed;
+ K.proof_context = [`Joint jo];
+ K.proof_apply_context = [];
+ K.proof_conclude =
+ { K.conclude_id = gen_id conclude_prefix seed;
+ K.conclude_aref = id;
+ K.conclude_method = "Exact";
+ K.conclude_args =
+ [ K.Premise
+ { K.premise_id = gen_id premise_prefix seed;
+ K.premise_xref = jo.K.joint_id;
+ K.premise_binder = Some "tiralo fuori";
+ K.premise_n = Some no;
+ }
+ ];
+ K.conclude_conclusion =
+ try Some
+ (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
+ with Not_found -> None
+ };
+ }
+ in
+ let id = get_id t in
+ generate_conversion seed false id t1 ~ids_to_inner_types
+in aux ?name t
+
+and inductive seed name id li ~ids_to_inner_types ~ids_to_inner_sorts =
+ let aux ?name = acic2content seed ~ids_to_inner_types ~ids_to_inner_sorts in
+ let module C2A = Cic2acic in
+ let module K = Content in
+ let module C = Cic in
+ match li with
+ C.AConst (idc,uri,exp_named_subst)::args ->
+ let uri_str = UriManager.string_of_uri uri in
+ let suffix = Str.regexp_string "_ind.con" in
+ let len = String.length uri_str in
+ let n = (try (Str.search_backward suffix uri_str len)
+ with Not_found -> -1) in
+ if n<0 then raise NotApplicable
+ else
+ let method_name =
+ if UriManager.eq uri HelmLibraryObjects.Logic.ex_ind_URI then "Exists"
+ else if UriManager.eq uri HelmLibraryObjects.Logic.and_ind_URI then "AndInd"
+ else if UriManager.eq uri HelmLibraryObjects.Logic.false_ind_URI then "FalseInd"
+ else "ByInduction" in
+ let prefix = String.sub uri_str 0 n in
+ let ind_str = (prefix ^ ".ind") in
+ let ind_uri = UriManager.uri_of_string ind_str in
+ let inductive_types,noparams =
+ (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph ind_uri in
+ match o with
+ | Cic.InductiveDefinition (l,_,n,_) -> (l,n)
+ | _ -> assert false
+ ) in
+ let rec split n l =
+ if n = 0 then ([],l) else
+ let p,a = split (n-1) (List.tl l) in
+ ((List.hd l::p),a) in
+ let params_and_IP,tail_args = split (noparams+1) args in
+ let constructors =
+ (match inductive_types with
+ [(_,_,_,l)] -> l
+ | _ -> raise NotApplicable) (* don't care for mutual ind *) in
+ let constructors1 =
+ let rec clean_up n t =
+ if n = 0 then t else
+ (match t with
+ (label,Cic.Prod (_,_,t)) -> clean_up (n-1) (label,t)
+ | _ -> assert false) in
+ List.map (clean_up noparams) constructors in
+ let no_constructors= List.length constructors in
+ let args_for_cases, other_args =
+ split no_constructors tail_args in
+ let subproofs,other_method_args =
+ build_subproofs_and_args seed other_args
+ ~ids_to_inner_types ~ids_to_inner_sorts in
+ let method_args=
+ let rec build_method_args =
+ function
+ [],_-> [] (* extra args are ignored ???? *)
+ | (name,ty)::tlc,arg::tla ->
+ let idarg = get_id arg in
+ let sortarg =
+ (try (Hashtbl.find ids_to_inner_sorts idarg)
+ with Not_found -> `Type (CicUniv.fresh())) in
+ let hdarg =
+ if sortarg = `Prop then
+ let (co,bo) =
+ let rec bc =
+ function
+ Cic.Prod (_,s,t),Cic.ALambda(idl,n,s1,t1) ->
+ let ce =
+ build_decl_item
+ seed idl n s1 ~ids_to_inner_sorts in
+ if (occur ind_uri s) then
+ ( match t1 with
+ Cic.ALambda(id2,n2,s2,t2) ->
+ let inductive_hyp =
+ `Hypothesis
+ { K.dec_name = name_of n2;
+ K.dec_id =
+ gen_id declaration_prefix seed;
+ K.dec_inductive = true;
+ K.dec_aref = id2;
+ K.dec_type = s2
+ } in
+ let (context,body) = bc (t,t2) in
+ (ce::inductive_hyp::context,body)
+ | _ -> assert false)
+ else
+ (
+ let (context,body) = bc (t,t1) in
+ (ce::context,body))
+ | _ , t -> ([],aux t) in
+ bc (ty,arg) in
+ K.ArgProof
+ { bo with
+ K.proof_name = Some name;
+ K.proof_context = co;
+ };
+ else (K.Term arg) in
+ hdarg::(build_method_args (tlc,tla))
+ | _ -> assert false in
+ build_method_args (constructors1,args_for_cases) in
+ { K.proof_name = name;
+ K.proof_id = gen_id proof_prefix seed;
+ K.proof_context = [];
+ K.proof_apply_context = serialize seed subproofs;
+ K.proof_conclude =
+ { K.conclude_id = gen_id conclude_prefix seed;
+ K.conclude_aref = id;
+ K.conclude_method = method_name;
+ K.conclude_args =
+ K.Aux (string_of_int no_constructors)
+ ::K.Term (C.AAppl(id,((C.AConst(idc,uri,exp_named_subst))::params_and_IP)))
+ ::method_args@other_method_args;
+ K.conclude_conclusion =
+ try Some
+ (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
+ with Not_found -> None
+ }
+ }
+ | _ -> raise NotApplicable
+
+and rewrite seed name id li ~ids_to_inner_types ~ids_to_inner_sorts =
+ let aux ?name = acic2content seed ~ids_to_inner_types ~ids_to_inner_sorts in
+ let module C2A = Cic2acic in
+ let module K = Content in
+ let module C = Cic in
+ match li with
+ C.AConst (sid,uri,exp_named_subst)::args ->
+ if UriManager.eq uri HelmLibraryObjects.Logic.eq_ind_URI or
+ UriManager.eq uri HelmLibraryObjects.Logic.eq_ind_r_URI then
+ let subproofs,arg =
+ (match
+ build_subproofs_and_args
+ seed ~ids_to_inner_types ~ids_to_inner_sorts [List.nth args 3]
+ with
+ l,[p] -> l,p
+ | _,_ -> assert false) in
+ let method_args =
+ let rec ma_aux n = function
+ [] -> []
+ | a::tl ->
+ let hd =
+ if n = 0 then arg
+ else
+ let aid = get_id a in
+ let asort = (try (Hashtbl.find ids_to_inner_sorts aid)
+ with Not_found -> `Type (CicUniv.fresh())) in
+ if asort = `Prop then
+ K.ArgProof (aux a)
+ else K.Term a in
+ hd::(ma_aux (n-1) tl) in
+ (ma_aux 3 args) in
+ { K.proof_name = name;
+ K.proof_id = gen_id proof_prefix seed;
+ K.proof_context = [];
+ K.proof_apply_context = serialize seed subproofs;
+ K.proof_conclude =
+ { K.conclude_id = gen_id conclude_prefix seed;
+ K.conclude_aref = id;
+ K.conclude_method = "Rewrite";
+ K.conclude_args =
+ K.Term (C.AConst (sid,uri,exp_named_subst))::method_args;
+ K.conclude_conclusion =
+ try Some
+ (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
+ with Not_found -> None
+ }
+ }
+ else raise NotApplicable
+ | _ -> raise NotApplicable
+;;
+
+let map_conjectures
+ seed ~ids_to_inner_sorts ~ids_to_inner_types (id,n,context,ty)
+=
+ let module K = Content in
+ let context' =
+ List.map
+ (function
+ (id,None) -> None
+ | (id,Some (name,Cic.ADecl t)) ->
+ Some
+ (* We should call build_decl_item, but we have not computed *)
+ (* the inner-types ==> we always produce a declaration *)
+ (`Declaration
+ { K.dec_name = name_of name;
+ K.dec_id = gen_id declaration_prefix seed;
+ K.dec_inductive = false;
+ K.dec_aref = get_id t;
+ K.dec_type = t
+ })
+ | (id,Some (name,Cic.ADef t)) ->
+ Some
+ (* We should call build_def_item, but we have not computed *)
+ (* the inner-types ==> we always produce a declaration *)
+ (`Definition
+ { K.def_name = name_of name;
+ K.def_id = gen_id definition_prefix seed;
+ K.def_aref = get_id t;
+ K.def_term = t
+ })
+ ) context
+ in
+ (id,n,context',ty)
+;;
+
+(* map_sequent is similar to map_conjectures, but the for the hid
+of the hypothesis, which are preserved instead of generating
+fresh ones. We shall have to adopt a uniform policy, soon or later *)
+
+let map_sequent ((id,n,context,ty):Cic.annconjecture) =
+ let module K = Content in
+ let context' =
+ List.map
+ (function
+ (id,None) -> None
+ | (id,Some (name,Cic.ADecl t)) ->
+ Some
+ (* We should call build_decl_item, but we have not computed *)
+ (* the inner-types ==> we always produce a declaration *)
+ (`Declaration
+ { K.dec_name = name_of name;
+ K.dec_id = id;
+ K.dec_inductive = false;
+ K.dec_aref = get_id t;
+ K.dec_type = t
+ })
+ | (id,Some (name,Cic.ADef t)) ->
+ Some
+ (* We should call build_def_item, but we have not computed *)
+ (* the inner-types ==> we always produce a declaration *)
+ (`Definition
+ { K.def_name = name_of name;
+ K.def_id = id;
+ K.def_aref = get_id t;
+ K.def_term = t
+ })
+ ) context
+ in
+ (id,n,context',ty)
+;;
+
+let rec annobj2content ~ids_to_inner_sorts ~ids_to_inner_types =
+ let module C = Cic in
+ let module K = Content in
+ let module C2A = Cic2acic in
+ let seed = ref 0 in
+ function
+ C.ACurrentProof (_,_,n,conjectures,bo,ty,params,_) ->
+ (gen_id object_prefix seed, params,
+ Some
+ (List.map
+ (map_conjectures seed ~ids_to_inner_sorts ~ids_to_inner_types)
+ conjectures),
+ `Def (K.Const,ty,
+ build_def_item seed (get_id bo) (C.Name n) bo
+ ~ids_to_inner_sorts ~ids_to_inner_types))
+ | C.AConstant (_,_,n,Some bo,ty,params,_) ->
+ (gen_id object_prefix seed, params, None,
+ `Def (K.Const,ty,
+ build_def_item seed (get_id bo) (C.Name n) bo
+ ~ids_to_inner_sorts ~ids_to_inner_types))
+ | C.AConstant (id,_,n,None,ty,params,_) ->
+ (gen_id object_prefix seed, params, None,
+ `Decl (K.Const,
+ build_decl_item seed id (C.Name n) ty
+ ~ids_to_inner_sorts))
+ | C.AVariable (_,n,Some bo,ty,params,_) ->
+ (gen_id object_prefix seed, params, None,
+ `Def (K.Var,ty,
+ build_def_item seed (get_id bo) (C.Name n) bo
+ ~ids_to_inner_sorts ~ids_to_inner_types))
+ | C.AVariable (id,n,None,ty,params,_) ->
+ (gen_id object_prefix seed, params, None,
+ `Decl (K.Var,
+ build_decl_item seed id (C.Name n) ty
+ ~ids_to_inner_sorts))
+ | C.AInductiveDefinition (id,l,params,nparams,_) ->
+ (gen_id object_prefix seed, params, None,
+ `Joint
+ { K.joint_id = gen_id joint_prefix seed;
+ K.joint_kind = `Inductive nparams;
+ K.joint_defs = List.map (build_inductive seed) l
+ })
+
+and
+ build_inductive seed =
+ let module K = Content in
+ fun (_,n,b,ty,l) ->
+ `Inductive
+ { K.inductive_id = gen_id inductive_prefix seed;
+ K.inductive_name = n;
+ K.inductive_kind = b;
+ K.inductive_type = ty;
+ K.inductive_constructors = build_constructors seed l
+ }
+
+and
+ build_constructors seed l =
+ let module K = Content in
+ List.map
+ (fun (n,t) ->
+ { K.dec_name = Some n;
+ K.dec_id = gen_id declaration_prefix seed;
+ K.dec_inductive = false;
+ K.dec_aref = "";
+ K.dec_type = t
+ }) l
+;;
+
+(*
+and 'term cinductiveType =
+ id * string * bool * 'term * (* typename, inductive, arity *)
+ 'term cconstructor list (* constructors *)
+
+and 'term cconstructor =
+ string * 'term
+*)
+
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val annobj2content :
+ ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t ->
+ ids_to_inner_types:(Cic.id, Cic2acic.anntypes) Hashtbl.t ->
+ Cic.annobj ->
+ Cic.annterm Content.cobj
+
+val map_sequent :
+ Cic.annconjecture -> Cic.annterm Content.conjecture
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+module Ast = CicNotationPt
+
+type value =
+ | TermValue of Ast.term
+ | StringValue of string
+ | NumValue of string
+ | OptValue of value option
+ | ListValue of value list
+
+type value_type =
+ | TermType
+ | StringType
+ | NumType
+ | OptType of value_type
+ | ListType of value_type
+
+exception Value_not_found of string
+exception Type_mismatch of string * value_type
+
+type declaration = string * value_type
+type binding = string * (value_type * value)
+type t = binding list
+
+let lookup env name =
+ try
+ List.assoc name env
+ with Not_found -> raise (Value_not_found name)
+
+let lookup_value env name =
+ try
+ snd (List.assoc name env)
+ with Not_found -> raise (Value_not_found name)
+
+let remove_name env name = List.remove_assoc name env
+
+let remove_names env names =
+ List.filter (fun name, _ -> not (List.mem name names)) env
+
+let lookup_term env name =
+ match lookup env name with
+ | _, TermValue x -> x
+ | ty, _ -> raise (Type_mismatch (name, ty))
+
+let lookup_num env name =
+ match lookup env name with
+ | _, NumValue x -> x
+ | ty, _ -> raise (Type_mismatch (name, ty))
+
+let lookup_string env name =
+ match lookup env name with
+ | _, StringValue x -> x
+ | ty, _ -> raise (Type_mismatch (name, ty))
+
+let lookup_opt env name =
+ match lookup env name with
+ | _, OptValue x -> x
+ | ty, _ -> raise (Type_mismatch (name, ty))
+
+let lookup_list env name =
+ match lookup env name with
+ | _, ListValue x -> x
+ | ty, _ -> raise (Type_mismatch (name, ty))
+
+let opt_binding_some (n, (ty, v)) = (n, (OptType ty, OptValue (Some v)))
+let opt_binding_none (n, (ty, v)) = (n, (OptType ty, OptValue None))
+let opt_binding_of_name (n, ty) = (n, (OptType ty, OptValue None))
+let list_binding_of_name (n, ty) = (n, (ListType ty, ListValue []))
+let opt_declaration (n, ty) = (n, OptType ty)
+let list_declaration (n, ty) = (n, ListType ty)
+
+let declaration_of_var = function
+ | Ast.NumVar s -> s, NumType
+ | Ast.IdentVar s -> s, StringType
+ | Ast.TermVar s -> s, TermType
+ | _ -> assert false
+
+let value_of_term = function
+ | Ast.Num (s, _) -> NumValue s
+ | Ast.Ident (s, None) -> StringValue s
+ | t -> TermValue t
+
+let term_of_value = function
+ | NumValue s -> Ast.Num (s, 0)
+ | StringValue s -> Ast.Ident (s, None)
+ | TermValue t -> t
+ | _ -> assert false (* TO BE UNDERSTOOD *)
+
+let rec well_typed ty value =
+ match ty, value with
+ | TermType, TermValue _
+ | StringType, StringValue _
+ | OptType _, OptValue None
+ | NumType, NumValue _ -> true
+ | OptType ty', OptValue (Some value') -> well_typed ty' value'
+ | ListType ty', ListValue vl ->
+ List.for_all (fun value' -> well_typed ty' value') vl
+ | _ -> false
+
+let declarations_of_env = List.map (fun (name, (ty, _)) -> (name, ty))
+let declarations_of_term p =
+ List.map declaration_of_var (CicNotationUtil.variables_of_term p)
+
+let rec combine decls values =
+ match decls, values with
+ | [], [] -> []
+ | (name, ty) :: decls, v :: values ->
+ (name, (ty, v)) :: (combine decls values)
+ | _ -> assert false
+
+let coalesce_env declarations env_list =
+ let env0 = List.map list_binding_of_name declarations in
+ let grow_env_entry env n v =
+ List.map
+ (function
+ | (n', (ty, ListValue vl)) as entry ->
+ if n' = n then n', (ty, ListValue (v :: vl)) else entry
+ | _ -> assert false)
+ env
+ in
+ let grow_env env_i env =
+ List.fold_left
+ (fun env (n, (_, v)) -> grow_env_entry env n v)
+ env env_i
+ in
+ List.fold_right grow_env env_list env0
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(** {2 Types} *)
+
+type value =
+ | TermValue of CicNotationPt.term
+ | StringValue of string
+ | NumValue of string
+ | OptValue of value option
+ | ListValue of value list
+
+type value_type =
+ | TermType
+ | StringType
+ | NumType
+ | OptType of value_type
+ | ListType of value_type
+
+ (** looked up value not found in environment *)
+exception Value_not_found of string
+
+ (** looked up value has the wrong type
+ * parameters are value name and value type in environment *)
+exception Type_mismatch of string * value_type
+
+type declaration = string * value_type
+type binding = string * (value_type * value)
+type t = binding list
+
+val declaration_of_var: CicNotationPt.pattern_variable -> declaration
+val value_of_term: CicNotationPt.term -> value
+val term_of_value: value -> CicNotationPt.term
+val well_typed: value_type -> value -> bool
+
+val declarations_of_env: t -> declaration list
+val declarations_of_term: CicNotationPt.term -> declaration list
+val combine: declaration list -> value list -> t (** @raise Invalid_argument *)
+
+(** {2 Environment lookup} *)
+
+val lookup_value: t -> string -> value (** @raise Value_not_found *)
+
+(** lookup_* functions below may raise Value_not_found and Type_mismatch *)
+
+val lookup_term: t -> string -> CicNotationPt.term
+val lookup_string: t -> string -> string
+val lookup_num: t -> string -> string
+val lookup_opt: t -> string -> value option
+val lookup_list: t -> string -> value list
+
+val remove_name: t -> string -> t
+val remove_names: t -> string list -> t
+
+(** {2 Bindings mangling} *)
+
+val opt_binding_some: binding -> binding (* v -> Some v *)
+val opt_binding_none: binding -> binding (* v -> None *)
+
+val opt_binding_of_name: declaration -> binding (* None binding *)
+val list_binding_of_name: declaration -> binding (* [] binding *)
+
+val opt_declaration: declaration -> declaration (* t -> OptType t *)
+val list_declaration: declaration -> declaration (* t -> ListType t *)
+
+(** given a list of environments bindings a set of names n_1, ..., n_k, returns
+ * a single environment where n_i is bound to the list of values bound in the
+ * starting environments *)
+val coalesce_env: declaration list -> t list -> t
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Printf
+
+module Ast = CicNotationPt
+module Env = CicNotationEnv
+
+ (* when set to true debugging information, not in sync with input syntax, will
+ * be added to the output of pp_term.
+ * set to false if you need, for example, cut and paste from matitac output to
+ * matitatop *)
+let debug_printing = true
+
+let pp_binder = function
+ | `Lambda -> "lambda"
+ | `Pi -> "Pi"
+ | `Exists -> "exists"
+ | `Forall -> "forall"
+
+let pp_literal =
+ if debug_printing then
+ (function (* debugging version *)
+ | `Symbol s -> sprintf "symbol(%s)" s
+ | `Keyword s -> sprintf "keyword(%s)" s
+ | `Number s -> sprintf "number(%s)" s)
+ else
+ (function
+ | `Symbol s
+ | `Keyword s
+ | `Number s -> s)
+
+let pp_assoc =
+ function
+ | Gramext.NonA -> "NonA"
+ | Gramext.LeftA -> "LeftA"
+ | Gramext.RightA -> "RightA"
+
+let pp_pos =
+ function
+(* `None -> "`None" *)
+ | `Left -> "`Left"
+ | `Right -> "`Right"
+ | `Inner -> "`Inner"
+
+let pp_attribute =
+ function
+ | `IdRef id -> sprintf "x(%s)" id
+ | `XmlAttrs attrs ->
+ sprintf "X(%s)"
+ (String.concat ";"
+ (List.map (fun (_, n, v) -> sprintf "%s=%s" n v) attrs))
+ | `Level (prec, assoc) -> sprintf "L(%d%s)" prec (pp_assoc assoc)
+ | `Raw _ -> "R"
+ | `Loc _ -> "@"
+ | `ChildPos p -> sprintf "P(%s)" (pp_pos p)
+
+let rec pp_term ?(pp_parens = true) t =
+ let t_pp =
+ match t with
+ | Ast.AttributedTerm (attr, term) when debug_printing ->
+ sprintf "%s[%s]" (pp_attribute attr) (pp_term ~pp_parens:false term)
+ | Ast.AttributedTerm (`Raw text, _) -> text
+ | Ast.AttributedTerm (_, term) -> pp_term ~pp_parens:false term
+ | Ast.Appl terms ->
+ sprintf "%s" (String.concat " " (List.map pp_term terms))
+ | Ast.Binder (`Forall, (Ast.Ident ("_", None), typ), body)
+ | Ast.Binder (`Pi, (Ast.Ident ("_", None), typ), body) ->
+ sprintf "%s \\to %s"
+ (match typ with None -> "?" | Some typ -> pp_term typ)
+ (pp_term body)
+ | Ast.Binder (kind, var, body) ->
+ sprintf "\\%s %s.%s" (pp_binder kind) (pp_capture_variable var)
+ (pp_term body)
+ | Ast.Case (term, indtype, typ, patterns) ->
+ sprintf "%smatch %s%s with %s"
+ (match typ with None -> "" | Some t -> sprintf "[%s]" (pp_term t))
+ (pp_term term)
+ (match indtype with
+ | None -> ""
+ | Some (ty, href_opt) ->
+ sprintf " in %s%s" ty
+ (match debug_printing, href_opt with
+ | true, Some uri ->
+ sprintf "(i.e.%s)" (UriManager.string_of_uri uri)
+ | _ -> ""))
+ (pp_patterns patterns)
+ | Ast.Cast (t1, t2) -> sprintf "(%s: %s)" (pp_term t1) (pp_term t2)
+ | Ast.LetIn (var, t1, t2) ->
+ sprintf "let %s = %s in %s" (pp_capture_variable var) (pp_term t1)
+ (pp_term t2)
+ | Ast.LetRec (kind, definitions, term) ->
+ sprintf "let %s %s in %s"
+ (match kind with `Inductive -> "rec" | `CoInductive -> "corec")
+ (String.concat " and "
+ (List.map
+ (fun (var, body, _) ->
+ sprintf "%s = %s" (pp_capture_variable var) (pp_term body))
+ definitions))
+ (pp_term term)
+ | Ast.Ident (name, Some []) | Ast.Ident (name, None)
+ | Ast.Uri (name, Some []) | Ast.Uri (name, None) ->
+ name
+ | Ast.Ident (name, Some substs)
+ | Ast.Uri (name, Some substs) ->
+ sprintf "%s \\subst [%s]" name (pp_substs substs)
+ | Ast.Implicit -> "?"
+ | Ast.Meta (index, substs) ->
+ sprintf "%d[%s]" index
+ (String.concat "; "
+ (List.map (function None -> "_" | Some t -> pp_term t) substs))
+ | Ast.Num (num, _) -> num
+ | Ast.Sort `Set -> "Set"
+ | Ast.Sort `Prop -> "Prop"
+ | Ast.Sort (`Type _) -> "Type"
+ | Ast.Sort `CProp -> "CProp"
+ | Ast.Symbol (name, _) -> "'" ^ name
+
+ | Ast.UserInput -> ""
+
+ | Ast.Literal l -> pp_literal l
+ | Ast.Layout l -> pp_layout l
+ | Ast.Magic m -> pp_magic m
+ | Ast.Variable v -> pp_variable v
+ in
+ if pp_parens then sprintf "(%s)" t_pp
+ else t_pp
+
+and pp_subst (name, term) = sprintf "%s \\Assign %s" name (pp_term term)
+and pp_substs substs = String.concat "; " (List.map pp_subst substs)
+
+and pp_pattern ((head, href, vars), term) =
+ let head_pp =
+ head ^
+ (match debug_printing, href with
+ | true, Some uri -> sprintf "(i.e.%s)" (UriManager.string_of_uri uri)
+ | _ -> "")
+ in
+ sprintf "%s \\Rightarrow %s"
+ (match vars with
+ | [] -> head_pp
+ | _ ->
+ sprintf "(%s %s)" head_pp
+ (String.concat " " (List.map pp_capture_variable vars)))
+ (pp_term term)
+
+and pp_patterns patterns =
+ sprintf "[%s]" (String.concat " | " (List.map pp_pattern patterns))
+
+and pp_capture_variable = function
+ | term, None -> pp_term term
+ | term, Some typ -> "(" ^ pp_term term ^ ": " ^ pp_term typ ^ ")"
+
+and pp_box_spec (kind, spacing, indent) =
+ let int_of_bool b = if b then 1 else 0 in
+ let kind_string =
+ match kind with
+ Ast.H -> "H" | Ast.V -> "V" | Ast.HV -> "HV" | Ast.HOV -> "HOV"
+ in
+ sprintf "%sBOX%d%d" kind_string (int_of_bool spacing) (int_of_bool indent)
+
+and pp_layout = function
+ | Ast.Sub (t1, t2) -> sprintf "%s \\SUB %s" (pp_term t1) (pp_term t2)
+ | Ast.Sup (t1, t2) -> sprintf "%s \\SUP %s" (pp_term t1) (pp_term t2)
+ | Ast.Below (t1, t2) -> sprintf "%s \\BELOW %s" (pp_term t1) (pp_term t2)
+ | Ast.Above (t1, t2) -> sprintf "%s \\ABOVE %s" (pp_term t1) (pp_term t2)
+ | Ast.Over (t1, t2) -> sprintf "[%s \\OVER %s]" (pp_term t1) (pp_term t2)
+ | Ast.Atop (t1, t2) -> sprintf "[%s \\ATOP %s]" (pp_term t1) (pp_term t2)
+ | Ast.Frac (t1, t2) -> sprintf "\\FRAC %s %s" (pp_term t1) (pp_term t2)
+ | Ast.Sqrt t -> sprintf "\\SQRT %s" (pp_term t)
+ | Ast.Root (arg, index) ->
+ sprintf "\\ROOT %s \\OF %s" (pp_term index) (pp_term arg)
+ | Ast.Break -> "\\BREAK"
+(* | Space -> "\\SPACE" *)
+ | Ast.Box (box_spec, terms) ->
+ sprintf "\\%s [%s]" (pp_box_spec box_spec)
+ (String.concat " " (List.map pp_term terms))
+ | Ast.Group terms ->
+ sprintf "\\GROUP [%s]" (String.concat " " (List.map pp_term terms))
+
+and pp_magic = function
+ | Ast.List0 (t, sep_opt) ->
+ sprintf "list0 %s%s" (pp_term t) (pp_sep_opt sep_opt)
+ | Ast.List1 (t, sep_opt) ->
+ sprintf "list1 %s%s" (pp_term t) (pp_sep_opt sep_opt)
+ | Ast.Opt t -> sprintf "opt %s" (pp_term t)
+ | Ast.Fold (kind, p_base, names, p_rec) ->
+ let acc = match names with acc :: _ -> acc | _ -> assert false in
+ sprintf "fold %s %s rec %s %s"
+ (pp_fold_kind kind) (pp_term p_base) acc (pp_term p_rec)
+ | Ast.Default (p_some, p_none) ->
+ sprintf "default %s %s" (pp_term p_some) (pp_term p_none)
+ | Ast.If (p_test, p_true, p_false) ->
+ sprintf "if %s then %s else %s"
+ (pp_term p_test) (pp_term p_true) (pp_term p_false)
+ | Ast.Fail -> "fail"
+
+and pp_fold_kind = function
+ | `Left -> "left"
+ | `Right -> "right"
+
+and pp_sep_opt = function
+ | None -> ""
+ | Some sep -> sprintf " sep %s" (pp_literal sep)
+
+and pp_variable = function
+ | Ast.NumVar s -> "number " ^ s
+ | Ast.IdentVar s -> "ident " ^ s
+ | Ast.TermVar s -> "term " ^ s
+ | Ast.Ascription (t, n) -> assert false
+ | Ast.FreshVar n -> "fresh " ^ n
+
+let pp_term t = pp_term ~pp_parens:false t
+
+let pp_params = function
+ | [] -> ""
+ | params ->
+ " " ^
+ String.concat " "
+ (List.map
+ (fun (name, typ) -> sprintf "(%s:%s)" name (pp_term typ))
+ params)
+
+let pp_flavour = function
+ | `Definition -> "Definition"
+ | `Fact -> "Fact"
+ | `Goal -> "Goal"
+ | `Lemma -> "Lemma"
+ | `Remark -> "Remark"
+ | `Theorem -> "Theorem"
+ | `Variant -> "Variant"
+
+let pp_fields fields =
+ (if fields <> [] then "\n" else "") ^
+ String.concat ";\n"
+ (List.map (fun (name,ty) -> " " ^ name ^ ": " ^ pp_term ty) fields)
+
+let pp_obj = function
+ | Ast.Inductive (params, types) ->
+ let pp_constructors constructors =
+ String.concat "\n"
+ (List.map (fun (name, typ) -> sprintf "| %s: %s" name (pp_term typ))
+ constructors)
+ in
+ let pp_type (name, _, typ, constructors) =
+ sprintf "\nwith %s: %s \\def\n%s" name (pp_term typ)
+ (pp_constructors constructors)
+ in
+ (match types with
+ | [] -> assert false
+ | (name, inductive, typ, constructors) :: tl ->
+ let fst_typ_pp =
+ sprintf "%sinductive %s%s: %s \\def\n%s"
+ (if inductive then "" else "co") name (pp_params params)
+ (pp_term typ) (pp_constructors constructors)
+ in
+ fst_typ_pp ^ String.concat "" (List.map pp_type tl))
+ | Ast.Theorem (flavour, name, typ, body) ->
+ sprintf "%s %s: %s %s"
+ (pp_flavour flavour)
+ name
+ (pp_term typ)
+ (match body with
+ | None -> ""
+ | Some body -> "\\def " ^ pp_term body)
+ | Ast.Record (params,name,ty,fields) ->
+ "record " ^ name ^ " " ^ pp_params params ^ " \\def {" ^
+ pp_fields fields ^ "}"
+
+let rec pp_value = function
+ | Env.TermValue t -> sprintf "$%s$" (pp_term t)
+ | Env.StringValue s -> sprintf "\"%s\"" s
+ | Env.NumValue n -> n
+ | Env.OptValue (Some v) -> "Some " ^ pp_value v
+ | Env.OptValue None -> "None"
+ | Env.ListValue l -> sprintf "[%s]" (String.concat "; " (List.map pp_value l))
+
+let rec pp_value_type =
+ function
+ | Env.TermType -> "Term"
+ | Env.StringType -> "String"
+ | Env.NumType -> "Number"
+ | Env.OptType t -> "Maybe " ^ pp_value_type t
+ | Env.ListType l -> "List " ^ pp_value_type l
+
+let pp_env env =
+ String.concat "; "
+ (List.map
+ (fun (name, (ty, value)) ->
+ sprintf "%s : %s = %s" name (pp_value_type ty) (pp_value value))
+ env)
+
+let rec pp_cic_appl_pattern = function
+ | Ast.UriPattern uri -> UriManager.string_of_uri uri
+ | Ast.VarPattern name -> name
+ | Ast.ImplicitPattern -> "_"
+ | Ast.ApplPattern aps ->
+ sprintf "(%s)" (String.concat " " (List.map pp_cic_appl_pattern aps))
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+val pp_term: CicNotationPt.term -> string
+val pp_obj: CicNotationPt.obj -> string
+
+val pp_env: CicNotationEnv.t -> string
+val pp_value: CicNotationEnv.value -> string
+val pp_value_type: CicNotationEnv.value_type -> string
+
+val pp_pos: CicNotationPt.child_pos -> string
+val pp_attribute: CicNotationPt.term_attribute -> string
+
+val pp_cic_appl_pattern: CicNotationPt.cic_appl_pattern -> string
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(** CIC Notation Parse Tree *)
+
+type binder_kind = [ `Lambda | `Pi | `Exists | `Forall ]
+type induction_kind = [ `Inductive | `CoInductive ]
+type sort_kind = [ `Prop | `Set | `Type of CicUniv.universe | `CProp ]
+type fold_kind = [ `Left | `Right ]
+
+type location = Token.flocation
+let fail floc msg =
+ let (x, y) = HExtlib.loc_of_floc floc in
+ failwith (Printf.sprintf "Error at characters %d - %d: %s" x y msg)
+
+type href = UriManager.uri
+
+type child_pos = [ `Left | `Right | `Inner ]
+
+type term_attribute =
+ [ `Loc of location (* source file location *)
+ | `IdRef of string (* ACic pointer *)
+ | `Level of int * Gramext.g_assoc (* precedence, associativity *)
+ | `ChildPos of child_pos (* position of l1 pattern variables *)
+ | `XmlAttrs of (string option * string * string) list
+ (* list of XML attributes: namespace, name, value *)
+ | `Raw of string (* unparsed version *)
+ ]
+
+type literal =
+ [ `Symbol of string
+ | `Keyword of string
+ | `Number of string
+ ]
+
+type case_indtype = string * href option
+
+(** To be increased each time the term type below changes, used for "safe"
+ * marshalling *)
+let magic = 1
+
+type term =
+ (* CIC AST *)
+
+ | AttributedTerm of term_attribute * term
+
+ | Appl of term list
+ | Binder of binder_kind * capture_variable * term (* kind, name, body *)
+ | Case of term * case_indtype option * term option *
+ (case_pattern * term) list
+ (* what to match, inductive type, out type, <pattern,action> list *)
+ | Cast of term * term
+ | LetIn of capture_variable * term * term (* name, body, where *)
+ | LetRec of induction_kind * (capture_variable * term * int) list * term
+ (* (name, body, decreasing argument) list, where *)
+ | Ident of string * subst list option
+ (* literal, substitutions.
+ * Some [] -> user has given an empty explicit substitution list
+ * None -> user has given no explicit substitution list *)
+ | Implicit
+ | Meta of int * meta_subst list
+ | Num of string * int (* literal, instance *)
+ | Sort of sort_kind
+ | Symbol of string * int (* canonical name, instance *)
+
+ | UserInput (* place holder for user input, used by MatitaConsole, not to be
+ used elsewhere *)
+ | Uri of string * subst list option (* as Ident, for long names *)
+
+ (* Syntax pattern extensions *)
+
+ | Literal of literal
+ | Layout of layout_pattern
+
+ | Magic of magic_term
+ | Variable of pattern_variable
+
+ (* name, type. First component must be Ident or Variable (FreshVar _) *)
+and capture_variable = term * term option
+
+and meta_subst = term option
+and subst = string * term
+and case_pattern = string * href option * capture_variable list
+
+and box_kind = H | V | HV | HOV
+and box_spec = box_kind * bool * bool (* kind, spacing, indent *)
+
+and layout_pattern =
+ | Sub of term * term
+ | Sup of term * term
+ | Below of term * term
+ | Above of term * term
+ | Frac of term * term
+ | Over of term * term
+ | Atop of term * term
+(* | array of term * literal option * literal option
+ |+ column separator, row separator +| *)
+ | Sqrt of term
+ | Root of term * term (* argument, index *)
+ | Break
+ | Box of box_spec * term list
+ | Group of term list
+
+and magic_term =
+ (* level 1 magics *)
+ | List0 of term * literal option (* pattern, separator *)
+ | List1 of term * literal option (* pattern, separator *)
+ | Opt of term
+
+ (* level 2 magics *)
+ | Fold of fold_kind * term * string list * term
+ (* base case pattern, recursive case bound names, recursive case pattern *)
+ | Default of term * term (* "some" case pattern, "none" case pattern *)
+ | Fail
+ | If of term * term * term (* test, pattern if true, pattern if false *)
+
+and pattern_variable =
+ (* level 1 and 2 variables *)
+ | NumVar of string
+ | IdentVar of string
+ | TermVar of string
+
+ (* level 1 variables *)
+ | Ascription of term * string
+
+ (* level 2 variables *)
+ | FreshVar of string
+
+type argument_pattern =
+ | IdentArg of int * string (* eta-depth, name *)
+
+type cic_appl_pattern =
+ | UriPattern of UriManager.uri
+ | VarPattern of string
+ | ImplicitPattern
+ | ApplPattern of cic_appl_pattern list
+
+ (** <name, inductive/coinductive, type, constructor list>
+ * true means inductive, false coinductive *)
+type 'term inductive_type = string * bool * 'term * (string * 'term) list
+
+type obj =
+ | Inductive of (string * term) list * term inductive_type list
+ (** parameters, list of loc * mutual inductive types *)
+ | Theorem of Cic.object_flavour * string * term * term option
+ (** flavour, name, type, body
+ * - name is absent when an unnamed theorem is being proved, tipically in
+ * interactive usage
+ * - body is present when its given along with the command, otherwise it
+ * will be given in proof editing mode using the tactical language
+ *)
+ | Record of (string * term) list * string * term * (string * term) list
+ (** left parameters, name, type, fields *)
+
+(** {2 Standard precedences} *)
+
+let let_in_prec = 10
+let binder_prec = 20
+let apply_prec = 70
+let simple_prec = 90
+
+let let_in_assoc = Gramext.NonA
+let binder_assoc = Gramext.RightA
+let apply_assoc = Gramext.LeftA
+let simple_assoc = Gramext.NonA
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+module Ast = CicNotationPt
+
+let visit_ast ?(special_k = fun _ -> assert false) k =
+ let rec aux = function
+ | Ast.Appl terms -> Ast.Appl (List.map k terms)
+ | Ast.Binder (kind, var, body) ->
+ Ast.Binder (kind, aux_capture_variable var, k body)
+ | Ast.Case (term, indtype, typ, patterns) ->
+ Ast.Case (k term, indtype, aux_opt typ, aux_patterns patterns)
+ | Ast.Cast (t1, t2) -> Ast.Cast (k t1, k t2)
+ | Ast.LetIn (var, t1, t2) ->
+ Ast.LetIn (aux_capture_variable var, k t1, k t2)
+ | Ast.LetRec (kind, definitions, term) ->
+ let definitions =
+ List.map
+ (fun (var, ty, n) -> aux_capture_variable var, k ty, n)
+ definitions
+ in
+ Ast.LetRec (kind, definitions, k term)
+ | Ast.Ident (name, Some substs) ->
+ Ast.Ident (name, Some (aux_substs substs))
+ | Ast.Uri (name, Some substs) -> Ast.Uri (name, Some (aux_substs substs))
+ | Ast.Meta (index, substs) -> Ast.Meta (index, List.map aux_opt substs)
+ | (Ast.AttributedTerm _
+ | Ast.Layout _
+ | Ast.Literal _
+ | Ast.Magic _
+ | Ast.Variable _) as t -> special_k t
+ | (Ast.Ident _
+ | Ast.Implicit
+ | Ast.Num _
+ | Ast.Sort _
+ | Ast.Symbol _
+ | Ast.Uri _
+ | Ast.UserInput) as t -> t
+ and aux_opt = function
+ | None -> None
+ | Some term -> Some (k term)
+ and aux_capture_variable (term, typ_opt) = k term, aux_opt typ_opt
+ and aux_patterns patterns = List.map aux_pattern patterns
+ and aux_pattern ((head, hrefs, vars), term) =
+ ((head, hrefs, List.map aux_capture_variable vars), k term)
+ and aux_subst (name, term) = (name, k term)
+ and aux_substs substs = List.map aux_subst substs
+ in
+ aux
+
+let visit_layout k = function
+ | Ast.Sub (t1, t2) -> Ast.Sub (k t1, k t2)
+ | Ast.Sup (t1, t2) -> Ast.Sup (k t1, k t2)
+ | Ast.Below (t1, t2) -> Ast.Below (k t1, k t2)
+ | Ast.Above (t1, t2) -> Ast.Above (k t1, k t2)
+ | Ast.Over (t1, t2) -> Ast.Over (k t1, k t2)
+ | Ast.Atop (t1, t2) -> Ast.Atop (k t1, k t2)
+ | Ast.Frac (t1, t2) -> Ast.Frac (k t1, k t2)
+ | Ast.Sqrt t -> Ast.Sqrt (k t)
+ | Ast.Root (arg, index) -> Ast.Root (k arg, k index)
+ | Ast.Break -> Ast.Break
+ | Ast.Box (kind, terms) -> Ast.Box (kind, List.map k terms)
+ | Ast.Group terms -> Ast.Group (List.map k terms)
+
+let visit_magic k = function
+ | Ast.List0 (t, l) -> Ast.List0 (k t, l)
+ | Ast.List1 (t, l) -> Ast.List1 (k t, l)
+ | Ast.Opt t -> Ast.Opt (k t)
+ | Ast.Fold (kind, t1, names, t2) -> Ast.Fold (kind, k t1, names, k t2)
+ | Ast.Default (t1, t2) -> Ast.Default (k t1, k t2)
+ | Ast.If (t1, t2, t3) -> Ast.If (k t1, k t2, k t3)
+ | Ast.Fail -> Ast.Fail
+
+let visit_variable k = function
+ | Ast.NumVar _
+ | Ast.IdentVar _
+ | Ast.TermVar _
+ | Ast.FreshVar _ as t -> t
+ | Ast.Ascription (t, s) -> Ast.Ascription (k t, s)
+
+let variables_of_term t =
+ let rec vars = ref [] in
+ let add_variable v =
+ if List.mem v !vars then ()
+ else vars := v :: !vars
+ in
+ let rec aux = function
+ | Ast.Magic m -> Ast.Magic (visit_magic aux m)
+ | Ast.Layout l -> Ast.Layout (visit_layout aux l)
+ | Ast.Variable v -> Ast.Variable (aux_variable v)
+ | Ast.Literal _ as t -> t
+ | Ast.AttributedTerm (_, t) -> aux t
+ | t -> visit_ast aux t
+ and aux_variable = function
+ | (Ast.NumVar _
+ | Ast.IdentVar _
+ | Ast.TermVar _) as t ->
+ add_variable t ;
+ t
+ | Ast.FreshVar _ as t -> t
+ | Ast.Ascription _ -> assert false
+ in
+ ignore (aux t) ;
+ !vars
+
+let names_of_term t =
+ let aux = function
+ | Ast.NumVar s
+ | Ast.IdentVar s
+ | Ast.TermVar s -> s
+ | _ -> assert false
+ in
+ List.map aux (variables_of_term t)
+
+let keywords_of_term t =
+ let rec keywords = ref [] in
+ let add_keyword k = keywords := k :: !keywords in
+ let rec aux = function
+ | Ast.AttributedTerm (_, t) -> aux t
+ | Ast.Layout l -> Ast.Layout (visit_layout aux l)
+ | Ast.Literal (`Keyword k) as t ->
+ add_keyword k;
+ t
+ | Ast.Literal _ as t -> t
+ | Ast.Magic m -> Ast.Magic (visit_magic aux m)
+ | Ast.Variable _ as v -> v
+ | t -> visit_ast aux t
+ in
+ ignore (aux t) ;
+ !keywords
+
+let rec strip_attributes t =
+ let special_k = function
+ | Ast.AttributedTerm (_, term) -> strip_attributes term
+ | Ast.Magic m -> Ast.Magic (visit_magic strip_attributes m)
+ | Ast.Variable _ as t -> t
+ | t -> assert false
+ in
+ visit_ast ~special_k strip_attributes t
+
+let rec get_idrefs =
+ function
+ | Ast.AttributedTerm (`IdRef id, t) -> id :: get_idrefs t
+ | Ast.AttributedTerm (_, t) -> get_idrefs t
+ | _ -> []
+
+let meta_names_of_term term =
+ let rec names = ref [] in
+ let add_name n =
+ if List.mem n !names then ()
+ else names := n :: !names
+ in
+ let rec aux = function
+ | Ast.AttributedTerm (_, term) -> aux term
+ | Ast.Appl terms -> List.iter aux terms
+ | Ast.Binder (_, _, body) -> aux body
+ | Ast.Case (term, indty, outty_opt, patterns) ->
+ aux term ;
+ aux_opt outty_opt ;
+ List.iter aux_branch patterns
+ | Ast.LetIn (_, t1, t2) ->
+ aux t1 ;
+ aux t2
+ | Ast.LetRec (_, definitions, body) ->
+ List.iter aux_definition definitions ;
+ aux body
+ | Ast.Uri (_, Some substs) -> aux_substs substs
+ | Ast.Ident (_, Some substs) -> aux_substs substs
+ | Ast.Meta (_, substs) -> aux_meta_substs substs
+
+ | Ast.Implicit
+ | Ast.Ident _
+ | Ast.Num _
+ | Ast.Sort _
+ | Ast.Symbol _
+ | Ast.Uri _
+ | Ast.UserInput -> ()
+
+ | Ast.Magic magic -> aux_magic magic
+ | Ast.Variable var -> aux_variable var
+
+ | _ -> assert false
+ and aux_opt = function
+ | Some term -> aux term
+ | None -> ()
+ and aux_capture_var (_, ty_opt) = aux_opt ty_opt
+ and aux_branch (pattern, term) =
+ aux_pattern pattern ;
+ aux term
+ and aux_pattern (head, _, vars) =
+ List.iter aux_capture_var vars
+ and aux_definition (var, term, i) =
+ aux_capture_var var ;
+ aux term
+ and aux_substs substs = List.iter (fun (_, term) -> aux term) substs
+ and aux_meta_substs meta_substs = List.iter aux_opt meta_substs
+ and aux_variable = function
+ | Ast.NumVar name -> add_name name
+ | Ast.IdentVar name -> add_name name
+ | Ast.TermVar name -> add_name name
+ | Ast.FreshVar _ -> ()
+ | Ast.Ascription _ -> assert false
+ and aux_magic = function
+ | Ast.Default (t1, t2)
+ | Ast.Fold (_, t1, _, t2) ->
+ aux t1 ;
+ aux t2
+ | Ast.If (t1, t2, t3) ->
+ aux t1 ;
+ aux t2 ;
+ aux t3
+ | Ast.Fail -> ()
+ | _ -> assert false
+ in
+ aux term ;
+ !names
+
+let rectangular matrix =
+ let columns = Array.length matrix.(0) in
+ try
+ Array.iter (fun a -> if Array.length a <> columns then raise Exit) matrix;
+ true
+ with Exit -> false
+
+let ncombine ll =
+ let matrix = Array.of_list (List.map Array.of_list ll) in
+ assert (rectangular matrix);
+ let rows = Array.length matrix in
+ let columns = Array.length matrix.(0) in
+ let lists = ref [] in
+ for j = 0 to columns - 1 do
+ let l = ref [] in
+ for i = 0 to rows - 1 do
+ l := matrix.(i).(j) :: !l
+ done;
+ lists := List.rev !l :: !lists
+ done;
+ List.rev !lists
+
+let string_of_literal = function
+ | `Symbol s
+ | `Keyword s
+ | `Number s -> s
+
+let boxify = function
+ | [ a ] -> a
+ | l -> Ast.Layout (Ast.Box ((Ast.H, false, false), l))
+
+let unboxify = function
+ | Ast.Layout (Ast.Box ((Ast.H, false, false), [ a ])) -> a
+ | l -> l
+
+let group = function
+ | [ a ] -> a
+ | l -> Ast.Layout (Ast.Group l)
+
+let ungroup =
+ let rec aux acc =
+ function
+ [] -> List.rev acc
+ | Ast.Layout (Ast.Group terms) :: terms' -> aux acc (terms @ terms')
+ | term :: terms -> aux (term :: acc) terms
+ in
+ aux []
+
+let dress ~sep:sauce =
+ let rec aux =
+ function
+ | [] -> []
+ | [hd] -> [hd]
+ | hd :: tl -> hd :: sauce :: aux tl
+ in
+ aux
+
+let dressn ~sep:sauces =
+ let rec aux =
+ function
+ | [] -> []
+ | [hd] -> [hd]
+ | hd :: tl -> hd :: sauces @ aux tl
+ in
+ aux
+
+let find_appl_pattern_uris ap =
+ let rec aux acc =
+ function
+ | Ast.UriPattern uri -> uri :: acc
+ | Ast.ImplicitPattern
+ | Ast.VarPattern _ -> acc
+ | Ast.ApplPattern apl -> List.fold_left aux acc apl
+ in
+ let uris = aux [] ap in
+ HExtlib.list_uniq (List.fast_sort UriManager.compare uris)
+
+let rec find_branch =
+ function
+ Ast.Magic (Ast.If (_, Ast.Magic Ast.Fail, t)) -> find_branch t
+ | Ast.Magic (Ast.If (_, t, _)) -> find_branch t
+ | t -> t
+
+let cic_name_of_name = function
+ | Ast.Ident ("_", None) -> Cic.Anonymous
+ | Ast.Ident (name, None) -> Cic.Name name
+ | _ -> assert false
+
+let name_of_cic_name =
+(* let add_dummy_xref t = Ast.AttributedTerm (`IdRef "", t) in *)
+ (* ZACK why we used to generate dummy xrefs? *)
+ let add_dummy_xref t = t in
+ function
+ | Cic.Name s -> add_dummy_xref (Ast.Ident (s, None))
+ | Cic.Anonymous -> add_dummy_xref (Ast.Ident ("_", None))
+
+let fresh_index = ref ~-1
+
+type notation_id = int
+
+let fresh_id () =
+ incr fresh_index;
+ !fresh_index
+
+ (* TODO ensure that names generated by fresh_var do not clash with user's *)
+let fresh_name () = "fresh" ^ string_of_int (fresh_id ())
+
+let rec freshen_term ?(index = ref 0) term =
+ let freshen_term = freshen_term ~index in
+ let fresh_instance () = incr index; !index in
+ let special_k = function
+ | Ast.AttributedTerm (attr, t) -> Ast.AttributedTerm (attr, freshen_term t)
+ | Ast.Layout l -> Ast.Layout (visit_layout freshen_term l)
+ | Ast.Magic m -> Ast.Magic (visit_magic freshen_term m)
+ | Ast.Variable v -> Ast.Variable (visit_variable freshen_term v)
+ | Ast.Literal _ as t -> t
+ | _ -> assert false
+ in
+ match term with
+ | Ast.Symbol (s, instance) -> Ast.Symbol (s, fresh_instance ())
+ | Ast.Num (s, instance) -> Ast.Num (s, fresh_instance ())
+ | t -> visit_ast ~special_k freshen_term t
+
+let freshen_obj obj =
+ let index = ref 0 in
+ let freshen_term = freshen_term ~index in
+ let freshen_name_ty = List.map (fun (n, t) -> (n, freshen_term t)) in
+ match obj with
+ | CicNotationPt.Inductive (params, indtypes) ->
+ let indtypes =
+ List.map
+ (fun (n, co, ty, ctors) -> (n, co, ty, freshen_name_ty ctors))
+ indtypes
+ in
+ CicNotationPt.Inductive (freshen_name_ty params, indtypes)
+ | CicNotationPt.Theorem (flav, n, t, ty_opt) ->
+ let ty_opt =
+ match ty_opt with None -> None | Some ty -> Some (freshen_term ty)
+ in
+ CicNotationPt.Theorem (flav, n, freshen_term t, ty_opt)
+ | CicNotationPt.Record (params, n, ty, fields) ->
+ CicNotationPt.Record (freshen_name_ty params, n, freshen_term ty,
+ freshen_name_ty fields)
+
+let freshen_term = freshen_term ?index:None
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+val fresh_name: unit -> string
+
+val variables_of_term: CicNotationPt.term -> CicNotationPt.pattern_variable list
+val names_of_term: CicNotationPt.term -> string list
+
+ (** extract all keywords (i.e. string literals) from a level 1 pattern *)
+val keywords_of_term: CicNotationPt.term -> string list
+
+val visit_ast:
+ ?special_k:(CicNotationPt.term -> CicNotationPt.term) ->
+ (CicNotationPt.term -> CicNotationPt.term) ->
+ CicNotationPt.term ->
+ CicNotationPt.term
+
+val visit_layout:
+ (CicNotationPt.term -> CicNotationPt.term) ->
+ CicNotationPt.layout_pattern ->
+ CicNotationPt.layout_pattern
+
+val visit_magic:
+ (CicNotationPt.term -> CicNotationPt.term) ->
+ CicNotationPt.magic_term ->
+ CicNotationPt.magic_term
+
+val visit_variable:
+ (CicNotationPt.term -> CicNotationPt.term) ->
+ CicNotationPt.pattern_variable ->
+ CicNotationPt.pattern_variable
+
+val strip_attributes: CicNotationPt.term -> CicNotationPt.term
+
+ (** @return the list of proper (i.e. non recursive) IdRef of a term *)
+val get_idrefs: CicNotationPt.term -> string list
+
+ (** generalization of List.combine to n lists *)
+val ncombine: 'a list list -> 'a list list
+
+val string_of_literal: CicNotationPt.literal -> string
+
+val dress: sep:'a -> 'a list -> 'a list
+val dressn: sep:'a list -> 'a list -> 'a list
+
+val boxify: CicNotationPt.term list -> CicNotationPt.term
+val group: CicNotationPt.term list -> CicNotationPt.term
+val ungroup: CicNotationPt.term list -> CicNotationPt.term list
+
+val find_appl_pattern_uris:
+ CicNotationPt.cic_appl_pattern -> UriManager.uri list
+
+val find_branch:
+ CicNotationPt.term -> CicNotationPt.term
+
+val cic_name_of_name: CicNotationPt.term -> Cic.name
+val name_of_cic_name: Cic.name -> CicNotationPt.term
+
+ (** Symbol/Numbers instances *)
+
+val freshen_term: CicNotationPt.term -> CicNotationPt.term
+val freshen_obj: CicNotationPt.obj -> CicNotationPt.obj
+
+ (** Notation id handling *)
+
+type notation_id
+
+val fresh_id: unit -> notation_id
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(**************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Andrea Asperti <asperti@cs.unibo.it> *)
+(* 16/6/2003 *)
+(* *)
+(**************************************************************************)
+
+type id = string;;
+type joint_recursion_kind =
+ [ `Recursive of int list
+ | `CoRecursive
+ | `Inductive of int (* paramsno *)
+ | `CoInductive of int (* paramsno *)
+ ]
+;;
+
+type var_or_const = Var | Const;;
+
+type 'term declaration =
+ { dec_name : string option;
+ dec_id : id ;
+ dec_inductive : bool;
+ dec_aref : string;
+ dec_type : 'term
+ }
+;;
+
+type 'term definition =
+ { def_name : string option;
+ def_id : id ;
+ def_aref : string ;
+ def_term : 'term
+ }
+;;
+
+type 'term inductive =
+ { inductive_id : id ;
+ inductive_name : string;
+ inductive_kind : bool;
+ inductive_type : 'term;
+ inductive_constructors : 'term declaration list
+ }
+;;
+
+type 'term decl_context_element =
+ [ `Declaration of 'term declaration
+ | `Hypothesis of 'term declaration
+ ]
+;;
+
+type ('term,'proof) def_context_element =
+ [ `Proof of 'proof
+ | `Definition of 'term definition
+ ]
+;;
+
+type ('term,'proof) in_joint_context_element =
+ [ `Inductive of 'term inductive
+ | 'term decl_context_element
+ | ('term,'proof) def_context_element
+ ]
+;;
+
+type ('term,'proof) joint =
+ { joint_id : id ;
+ joint_kind : joint_recursion_kind ;
+ joint_defs : ('term,'proof) in_joint_context_element list
+ }
+;;
+
+type ('term,'proof) joint_context_element =
+ [ `Joint of ('term,'proof) joint ]
+;;
+
+type 'term proof =
+ { proof_name : string option;
+ proof_id : id ;
+ proof_context : 'term in_proof_context_element list ;
+ proof_apply_context: 'term proof list;
+ proof_conclude : 'term conclude_item
+ }
+
+and 'term in_proof_context_element =
+ [ 'term decl_context_element
+ | ('term,'term proof) def_context_element
+ | ('term,'term proof) joint_context_element
+ ]
+
+and 'term conclude_item =
+ { conclude_id : id;
+ conclude_aref : string;
+ conclude_method : string;
+ conclude_args : ('term arg) list ;
+ conclude_conclusion : 'term option
+ }
+
+and 'term arg =
+ Aux of string
+ | Premise of premise
+ | Lemma of lemma
+ | Term of 'term
+ | ArgProof of 'term proof
+ | ArgMethod of string (* ???? *)
+
+and premise =
+ { premise_id: id;
+ premise_xref : string ;
+ premise_binder : string option;
+ premise_n : int option;
+ }
+
+and lemma =
+ { lemma_id: id;
+ lemma_name: string;
+ lemma_uri: string
+ }
+
+;;
+
+type 'term conjecture = id * int * 'term context * 'term
+
+and 'term context = 'term hypothesis list
+
+and 'term hypothesis =
+ ['term decl_context_element | ('term,'term proof) def_context_element ] option
+;;
+
+type 'term in_object_context_element =
+ [ `Decl of var_or_const * 'term decl_context_element
+ | `Def of var_or_const * 'term * ('term,'term proof) def_context_element
+ | ('term,'term proof) joint_context_element
+ ]
+;;
+
+type 'term cobj =
+ id * (* id *)
+ UriManager.uri list * (* params *)
+ 'term conjecture list option * (* optional metasenv *)
+ 'term in_object_context_element (* actual object *)
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+type id = string;;
+type joint_recursion_kind =
+ [ `Recursive of int list (* decreasing arguments *)
+ | `CoRecursive
+ | `Inductive of int (* paramsno *)
+ | `CoInductive of int (* paramsno *)
+ ]
+;;
+
+type var_or_const = Var | Const;;
+
+type 'term declaration =
+ { dec_name : string option;
+ dec_id : id ;
+ dec_inductive : bool;
+ dec_aref : string;
+ dec_type : 'term
+ }
+;;
+
+type 'term definition =
+ { def_name : string option;
+ def_id : id ;
+ def_aref : string ;
+ def_term : 'term
+ }
+;;
+
+type 'term inductive =
+ { inductive_id : id ;
+ inductive_name : string;
+ inductive_kind : bool;
+ inductive_type : 'term;
+ inductive_constructors : 'term declaration list
+ }
+;;
+
+type 'term decl_context_element =
+ [ `Declaration of 'term declaration
+ | `Hypothesis of 'term declaration
+ ]
+;;
+
+type ('term,'proof) def_context_element =
+ [ `Proof of 'proof
+ | `Definition of 'term definition
+ ]
+;;
+
+type ('term,'proof) in_joint_context_element =
+ [ `Inductive of 'term inductive
+ | 'term decl_context_element
+ | ('term,'proof) def_context_element
+ ]
+;;
+
+type ('term,'proof) joint =
+ { joint_id : id ;
+ joint_kind : joint_recursion_kind ;
+ joint_defs : ('term,'proof) in_joint_context_element list
+ }
+;;
+
+type ('term,'proof) joint_context_element =
+ [ `Joint of ('term,'proof) joint ]
+;;
+
+type 'term proof =
+ { proof_name : string option;
+ proof_id : id ;
+ proof_context : 'term in_proof_context_element list ;
+ proof_apply_context: 'term proof list;
+ proof_conclude : 'term conclude_item
+ }
+
+and 'term in_proof_context_element =
+ [ 'term decl_context_element
+ | ('term,'term proof) def_context_element
+ | ('term,'term proof) joint_context_element
+ ]
+
+and 'term conclude_item =
+ { conclude_id : id;
+ conclude_aref : string;
+ conclude_method : string;
+ conclude_args : ('term arg) list ;
+ conclude_conclusion : 'term option
+ }
+
+and 'term arg =
+ Aux of string
+ | Premise of premise
+ | Lemma of lemma
+ | Term of 'term
+ | ArgProof of 'term proof
+ | ArgMethod of string (* ???? *)
+
+and premise =
+ { premise_id: id;
+ premise_xref : string ;
+ premise_binder : string option;
+ premise_n : int option;
+ }
+
+and lemma =
+ { lemma_id: id;
+ lemma_name : string;
+ lemma_uri: string
+ }
+;;
+
+type 'term conjecture = id * int * 'term context * 'term
+
+and 'term context = 'term hypothesis list
+
+and 'term hypothesis =
+ ['term decl_context_element | ('term,'term proof) def_context_element ] option
+;;
+
+type 'term in_object_context_element =
+ [ `Decl of var_or_const * 'term decl_context_element
+ | `Def of var_or_const * 'term * ('term,'term proof) def_context_element
+ | ('term,'term proof) joint_context_element
+ ]
+;;
+
+type 'term cobj =
+ id * (* id *)
+ UriManager.uri list * (* params *)
+ 'term conjecture list option * (* optional metasenv *)
+ 'term in_object_context_element (* actual object *)
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(***************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Andrea Asperti <asperti@cs.unibo.it> *)
+(* 17/06/2003 *)
+(* *)
+(***************************************************************************)
+
+exception TO_DO;;
+
+let proof2cic deannotate p =
+ let rec proof2cic premise_env p =
+ let module C = Cic in
+ let module Con = Content in
+ let rec extend_premise_env current_env =
+ function
+ [] -> current_env
+ | p::atl ->
+ extend_premise_env
+ ((p.Con.proof_id,(proof2cic current_env p))::current_env) atl in
+ let new_premise_env = extend_premise_env premise_env p.Con.proof_apply_context in
+ let body = conclude2cic new_premise_env p.Con.proof_conclude in
+ context2cic premise_env p.Con.proof_context body
+
+ and context2cic premise_env context body =
+ List.fold_right (ce2cic premise_env) context body
+
+ and ce2cic premise_env ce target =
+ let module C = Cic in
+ let module Con = Content in
+ match ce with
+ `Declaration d ->
+ (match d.Con.dec_name with
+ Some s ->
+ C.Lambda (C.Name s, deannotate d.Con.dec_type, target)
+ | None ->
+ C.Lambda (C.Anonymous, deannotate d.Con.dec_type, target))
+ | `Hypothesis h ->
+ (match h.Con.dec_name with
+ Some s ->
+ C.Lambda (C.Name s, deannotate h.Con.dec_type, target)
+ | None ->
+ C.Lambda (C.Anonymous, deannotate h.Con.dec_type, target))
+ | `Proof p ->
+ (match p.Con.proof_name with
+ Some s ->
+ C.LetIn (C.Name s, proof2cic premise_env p, target)
+ | None ->
+ C.LetIn (C.Anonymous, proof2cic premise_env p, target))
+ | `Definition d ->
+ (match d.Con.def_name with
+ Some s ->
+ C.LetIn (C.Name s, proof2cic premise_env p, target)
+ | None ->
+ C.LetIn (C.Anonymous, proof2cic premise_env p, target))
+ | `Joint {Con.joint_kind = kind; Con.joint_defs = defs} ->
+ (match target with
+ C.Rel n ->
+ (match kind with
+ `Recursive l ->
+ let funs =
+ List.map2
+ (fun n bo ->
+ match bo with
+ `Proof bo ->
+ (match
+ bo.Con.proof_conclude.Con.conclude_conclusion,
+ bo.Con.proof_name
+ with
+ Some ty, Some name ->
+ (name,n,deannotate ty,
+ proof2cic premise_env bo)
+ | _,_ -> assert false)
+ | _ -> assert false)
+ l defs in
+ C.Fix (n, funs)
+ | `CoRecursive ->
+ let funs =
+ List.map
+ (function bo ->
+ match bo with
+ `Proof bo ->
+ (match
+ bo.Con.proof_conclude.Con.conclude_conclusion,
+ bo.Con.proof_name
+ with
+ Some ty, Some name ->
+ (name,deannotate ty,
+ proof2cic premise_env bo)
+ | _,_ -> assert false)
+ | _ -> assert false)
+ defs in
+ C.CoFix (n, funs)
+ | _ -> (* no inductive types in local contexts *)
+ assert false)
+ | _ -> assert false)
+
+ and conclude2cic premise_env conclude =
+ let module C = Cic in
+ let module Con = Content in
+ if conclude.Con.conclude_method = "TD_Conversion" then
+ (match conclude.Con.conclude_args with
+ [Con.ArgProof p] -> proof2cic [] p (* empty! *)
+ | _ -> prerr_endline "1"; assert false)
+ else if conclude.Con.conclude_method = "BU_Conversion" then
+ (match conclude.Con.conclude_args with
+ [Con.Premise prem] ->
+ (try List.assoc prem.Con.premise_xref premise_env
+ with Not_found ->
+ prerr_endline
+ ("Not_found in BU_Conversion: " ^ prem.Con.premise_xref);
+ raise Not_found)
+ | _ -> prerr_endline "2"; assert false)
+ else if conclude.Con.conclude_method = "Exact" then
+ (match conclude.Con.conclude_args with
+ [Con.Term t] -> deannotate t
+ | [Con.Premise prem] ->
+ (match prem.Con.premise_n with
+ None -> assert false
+ | Some n -> C.Rel n)
+ | _ -> prerr_endline "3"; assert false)
+ else if conclude.Con.conclude_method = "Intros+LetTac" then
+ (match conclude.Con.conclude_args with
+ [Con.ArgProof p] -> proof2cic [] p (* empty! *)
+ | _ -> prerr_endline "4"; assert false)
+ else if (conclude.Con.conclude_method = "ByInduction" ||
+ conclude.Con.conclude_method = "AndInd" ||
+ conclude.Con.conclude_method = "Exists" ||
+ conclude.Con.conclude_method = "FalseInd") then
+ (match (List.tl conclude.Con.conclude_args) with
+ Con.Term (C.AAppl (
+ id,((C.AConst(idc,uri,exp_named_subst))::params_and_IP)))::args ->
+ let subst =
+ List.map (fun (u,t) -> (u, deannotate t)) exp_named_subst in
+ let cargs = args2cic premise_env args in
+ let cparams_and_IP = List.map deannotate params_and_IP in
+ C.Appl (C.Const(uri,subst)::cparams_and_IP@cargs)
+ | _ -> prerr_endline "5"; assert false)
+ else if (conclude.Con.conclude_method = "Rewrite") then
+ (match conclude.Con.conclude_args with
+ Con.Term (C.AConst (sid,uri,exp_named_subst))::args ->
+ let subst =
+ List.map (fun (u,t) -> (u, deannotate t)) exp_named_subst in
+ let cargs = args2cic premise_env args in
+ C.Appl (C.Const(uri,subst)::cargs)
+ | _ -> prerr_endline "6"; assert false)
+ else if (conclude.Con.conclude_method = "Case") then
+ (match conclude.Con.conclude_args with
+ Con.Aux(uri)::Con.Aux(notype)::Con.Term(ty)::Con.Premise(prem)::patterns ->
+ C.MutCase
+ (UriManager.uri_of_string uri,
+ int_of_string notype, deannotate ty,
+ List.assoc prem.Con.premise_xref premise_env,
+ List.map
+ (function
+ Con.ArgProof p -> proof2cic [] p
+ | _ -> prerr_endline "7a"; assert false) patterns)
+ | Con.Aux(uri)::Con.Aux(notype)::Con.Term(ty)::Con.Term(te)::patterns -> C.MutCase
+ (UriManager.uri_of_string uri,
+ int_of_string notype, deannotate ty, deannotate te,
+ List.map
+ (function
+ (Con.ArgProof p) -> proof2cic [] p
+ | _ -> prerr_endline "7a"; assert false) patterns)
+ | _ -> (prerr_endline "7"; assert false))
+ else if (conclude.Con.conclude_method = "Apply") then
+ let cargs = (args2cic premise_env conclude.Con.conclude_args) in
+ C.Appl cargs
+ else (prerr_endline "8"; assert false)
+
+ and args2cic premise_env l =
+ List.map (arg2cic premise_env) l
+
+ and arg2cic premise_env =
+ let module C = Cic in
+ let module Con = Content in
+ function
+ Con.Aux n -> prerr_endline "8"; assert false
+ | Con.Premise prem ->
+ (match prem.Con.premise_n with
+ Some n -> C.Rel n
+ | None ->
+ (try List.assoc prem.Con.premise_xref premise_env
+ with Not_found ->
+ prerr_endline ("Not_found in arg2cic: premise " ^ (match prem.Con.premise_binder with None -> "previous" | Some p -> p) ^ ", xref=" ^ prem.Con.premise_xref);
+ raise Not_found))
+ | Con.Lemma lemma ->
+ CicUtil.term_of_uri (UriManager.uri_of_string lemma.Con.lemma_uri)
+ | Con.Term t -> deannotate t
+ | Con.ArgProof p -> proof2cic [] p (* empty! *)
+ | Con.ArgMethod s -> raise TO_DO
+
+in proof2cic [] p
+;;
+
+exception ToDo;;
+
+let cobj2obj deannotate (id,params,metasenv,obj) =
+ let module K = Content in
+ match obj with
+ `Def (Content.Const,ty,`Proof bo) ->
+ (match metasenv with
+ None ->
+ Cic.Constant
+ (id, Some (proof2cic deannotate bo), deannotate ty, params, [])
+ | Some metasenv' ->
+ let metasenv'' =
+ List.map
+ (function (_,i,canonical_context,term) ->
+ let canonical_context' =
+ List.map
+ (function
+ None -> None
+ | Some (`Declaration d)
+ | Some (`Hypothesis d) ->
+ (match d with
+ {K.dec_name = Some n ; K.dec_type = t} ->
+ Some (Cic.Name n, Cic.Decl (deannotate t))
+ | _ -> assert false)
+ | Some (`Definition d) ->
+ (match d with
+ {K.def_name = Some n ; K.def_term = t} ->
+ Some (Cic.Name n, Cic.Def ((deannotate t),None))
+ | _ -> assert false)
+ | Some (`Proof d) ->
+ (match d with
+ {K.proof_name = Some n } ->
+ Some (Cic.Name n,
+ Cic.Def ((proof2cic deannotate d),None))
+ | _ -> assert false)
+ ) canonical_context
+ in
+ (i,canonical_context',deannotate term)
+ ) metasenv'
+ in
+ Cic.CurrentProof
+ (id, metasenv'', proof2cic deannotate bo, deannotate ty, params,
+ []))
+ | _ -> raise ToDo
+;;
+
+let cobj2obj = cobj2obj Deannotate.deannotate_term;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(**************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Andrea Asperti <asperti@cs.unibo.it> *)
+(* 27/6/2003 *)
+(* *)
+(**************************************************************************)
+
+val cobj2obj : Cic.annterm Content.cobj -> Cic.obj
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(***************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Andrea Asperti <asperti@cs.unibo.it> *)
+(* 17/06/2003 *)
+(* *)
+(***************************************************************************)
+
+exception ContentPpInternalError;;
+exception NotEnoughElements;;
+exception TO_DO
+
+(* Utility functions *)
+
+
+let string_of_name =
+ function
+ Some s -> s
+ | None -> "_"
+;;
+
+(* get_nth l n returns the nth element of the list l if it exists or *)
+(* raises NotEnoughElements if l has less than n elements *)
+let rec get_nth l n =
+ match (n,l) with
+ (1, he::_) -> he
+ | (n, he::tail) when n > 1 -> get_nth tail (n-1)
+ | (_,_) -> raise NotEnoughElements
+;;
+
+let rec blanks n =
+ if n = 0 then ""
+ else (" " ^ (blanks (n-1)));;
+
+let rec pproof (p: Cic.annterm Content.proof) indent =
+ let module Con = Content in
+ let new_indent =
+ (match p.Con.proof_name with
+ Some s ->
+ prerr_endline
+ ((blanks indent) ^ "(" ^ s ^ ")"); flush stderr ;(indent + 1)
+ | None ->indent) in
+ let new_indent1 =
+ if (p.Con.proof_context = []) then new_indent
+ else
+ (pcontext p.Con.proof_context new_indent; (new_indent + 1)) in
+ papply_context p.Con.proof_apply_context new_indent1;
+ pconclude p.Con.proof_conclude new_indent1;
+
+and pcontext c indent =
+ List.iter (pcontext_element indent) c
+
+and pcontext_element indent =
+ let module Con = Content in
+ function
+ `Declaration d ->
+ (match d.Con.dec_name with
+ Some s ->
+ prerr_endline
+ ((blanks indent)
+ ^ "Assume " ^ s ^ " : "
+ ^ (CicPp.ppterm (Deannotate.deannotate_term d.Con.dec_type)));
+ flush stderr
+ | None ->
+ prerr_endline ((blanks indent) ^ "NO NAME!!"))
+ | `Hypothesis h ->
+ (match h.Con.dec_name with
+ Some s ->
+ prerr_endline
+ ((blanks indent)
+ ^ "Suppose " ^ s ^ " : "
+ ^ (CicPp.ppterm (Deannotate.deannotate_term h.Con.dec_type)));
+ flush stderr
+ | None ->
+ prerr_endline ((blanks indent) ^ "NO NAME!!"))
+ | `Proof p -> pproof p indent
+ | `Definition d ->
+ (match d.Con.def_name with
+ Some s ->
+ prerr_endline
+ ((blanks indent) ^ "Let " ^ s ^ " = "
+ ^ (CicPp.ppterm (Deannotate.deannotate_term d.Con.def_term)));
+ flush stderr
+ | None ->
+ prerr_endline ((blanks indent) ^ "NO NAME!!"))
+ | `Joint ho ->
+ prerr_endline ((blanks indent) ^ "Joint Def");
+ flush stderr
+
+and papply_context ac indent =
+ List.iter(function p -> (pproof p indent)) ac
+
+and pconclude concl indent =
+ let module Con = Content in
+ prerr_endline ((blanks indent) ^ "Apply method " ^ concl.Con.conclude_method ^ " to");flush stderr;
+ pargs concl.Con.conclude_args indent;
+ match concl.Con.conclude_conclusion with
+ None -> prerr_endline ((blanks indent) ^"No conclude conclusion");flush stderr
+ | Some t -> prerr_endline ((blanks indent) ^ "conclude" ^ concl.Con.conclude_method ^ (CicPp.ppterm (Deannotate.deannotate_term t)));flush stderr
+
+and pargs args indent =
+ List.iter (parg indent) args
+
+and parg indent =
+ let module Con = Content in
+ function
+ Con.Aux n -> prerr_endline ((blanks (indent+1)) ^ n)
+ | Con.Premise prem -> prerr_endline ((blanks (indent+1)) ^ "Premise")
+ | Con.Lemma lemma -> prerr_endline ((blanks (indent+1)) ^ "Lemma")
+ | Con.Term t ->
+ prerr_endline ((blanks (indent+1)) ^ (CicPp.ppterm (Deannotate.deannotate_term t)))
+ | Con.ArgProof p -> pproof p (indent+1)
+ | Con.ArgMethod s -> prerr_endline ((blanks (indent+1)) ^ "A Method !!!")
+;;
+
+let print_proof p = pproof p 0;;
+
+let print_obj (_,_,_,obj) =
+ match obj with
+ `Decl (_,decl) ->
+ pcontext_element 0 (decl:> Cic.annterm Content.in_proof_context_element)
+ | `Def (_,_,def) ->
+ pcontext_element 0 (def:> Cic.annterm Content.in_proof_context_element)
+ | `Joint _ as jo -> pcontext_element 0 jo
+;;
+
+
+
+
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val print_proof: Cic.annterm Content.proof -> unit
+
+val print_obj: Cic.annterm Content.cobj -> unit
+
+val parg: int -> Cic.annterm Content.arg ->unit
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Printf
+
+module Ast = CicNotationPt
+
+let debug = false
+let debug_print s = if debug then prerr_endline (Lazy.force s) else ()
+
+type interpretation_id = int
+
+let idref id t = Ast.AttributedTerm (`IdRef id, t)
+
+type term_info =
+ { sort: (Cic.id, Ast.sort_kind) Hashtbl.t;
+ uri: (Cic.id, UriManager.uri) Hashtbl.t;
+ }
+
+let get_types uri =
+ let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ match o with
+ | Cic.InductiveDefinition (l,_,_,_) -> l
+ | _ -> assert false
+
+let name_of_inductive_type uri i =
+ let types = get_types uri in
+ let (name, _, _, _) = try List.nth types i with Not_found -> assert false in
+ name
+
+ (* returns <name, type> pairs *)
+let constructors_of_inductive_type uri i =
+ let types = get_types uri in
+ let (_, _, _, constructors) =
+ try List.nth types i with Not_found -> assert false
+ in
+ constructors
+
+ (* returns name only *)
+let constructor_of_inductive_type uri i j =
+ (try
+ fst (List.nth (constructors_of_inductive_type uri i) (j-1))
+ with Not_found -> assert false)
+
+let ast_of_acic0 term_info acic k =
+ let k = k term_info in
+ let id_to_uris = term_info.uri in
+ let register_uri id uri = Hashtbl.add id_to_uris id uri in
+ let sort_of_id id =
+ try
+ Hashtbl.find term_info.sort id
+ with Not_found ->
+ prerr_endline (sprintf "warning: sort of id %s not found, using Type" id);
+ `Type (CicUniv.fresh ())
+ in
+ let aux_substs substs =
+ Some
+ (List.map
+ (fun (uri, annterm) -> (UriManager.name_of_uri uri, k annterm))
+ substs)
+ in
+ let aux_context context =
+ List.map
+ (function
+ | None -> None
+ | Some annterm -> Some (k annterm))
+ context
+ in
+ let aux = function
+ | Cic.ARel (id,_,_,b) -> idref id (Ast.Ident (b, None))
+ | Cic.AVar (id,uri,substs) ->
+ register_uri id uri;
+ idref id (Ast.Ident (UriManager.name_of_uri uri, aux_substs substs))
+ | Cic.AMeta (id,n,l) -> idref id (Ast.Meta (n, aux_context l))
+ | Cic.ASort (id,Cic.Prop) -> idref id (Ast.Sort `Prop)
+ | Cic.ASort (id,Cic.Set) -> idref id (Ast.Sort `Set)
+ | Cic.ASort (id,Cic.Type u) -> idref id (Ast.Sort (`Type u))
+ | Cic.ASort (id,Cic.CProp) -> idref id (Ast.Sort `CProp)
+ | Cic.AImplicit (id, Some `Hole) -> idref id Ast.UserInput
+ | Cic.AImplicit (id, _) -> idref id Ast.Implicit
+ | Cic.AProd (id,n,s,t) ->
+ let binder_kind =
+ match sort_of_id id with
+ | `Set | `Type _ -> `Pi
+ | `Prop | `CProp -> `Forall
+ in
+ idref id (Ast.Binder (binder_kind,
+ (CicNotationUtil.name_of_cic_name n, Some (k s)), k t))
+ | Cic.ACast (id,v,t) -> idref id (Ast.Cast (k v, k t))
+ | Cic.ALambda (id,n,s,t) ->
+ idref id (Ast.Binder (`Lambda,
+ (CicNotationUtil.name_of_cic_name n, Some (k s)), k t))
+ | Cic.ALetIn (id,n,s,t) ->
+ idref id (Ast.LetIn ((CicNotationUtil.name_of_cic_name n, None),
+ k s, k t))
+ | Cic.AAppl (aid,args) -> idref aid (Ast.Appl (List.map k args))
+ | Cic.AConst (id,uri,substs) ->
+ register_uri id uri;
+ idref id (Ast.Ident (UriManager.name_of_uri uri, aux_substs substs))
+ | Cic.AMutInd (id,uri,i,substs) as t ->
+ let name = name_of_inductive_type uri i in
+ let uri_str = UriManager.string_of_uri uri in
+ let puri_str = sprintf "%s#xpointer(1/%d)" uri_str (i+1) in
+ register_uri id (UriManager.uri_of_string puri_str);
+ idref id (Ast.Ident (name, aux_substs substs))
+ | Cic.AMutConstruct (id,uri,i,j,substs) ->
+ let name = constructor_of_inductive_type uri i j in
+ let uri_str = UriManager.string_of_uri uri in
+ let puri_str = sprintf "%s#xpointer(1/%d/%d)" uri_str (i + 1) j in
+ register_uri id (UriManager.uri_of_string puri_str);
+ idref id (Ast.Ident (name, aux_substs substs))
+ | Cic.AMutCase (id,uri,typeno,ty,te,patterns) ->
+ let name = name_of_inductive_type uri typeno in
+ let uri_str = UriManager.string_of_uri uri in
+ let puri_str = sprintf "%s#xpointer(1/%d)" uri_str (typeno+1) in
+ let ctor_puri j =
+ UriManager.uri_of_string
+ (sprintf "%s#xpointer(1/%d/%d)" uri_str (typeno+1) j)
+ in
+ let case_indty = name, Some (UriManager.uri_of_string puri_str) in
+ let constructors = constructors_of_inductive_type uri typeno in
+ let rec eat_branch ty pat =
+ match (ty, pat) with
+ | Cic.Prod (_, _, t), Cic.ALambda (_, name, s, t') ->
+ let (cv, rhs) = eat_branch t t' in
+ (CicNotationUtil.name_of_cic_name name, Some (k s)) :: cv, rhs
+ | _, _ -> [], k pat
+ in
+ let j = ref 0 in
+ let patterns =
+ try
+ List.map2
+ (fun (name, ty) pat ->
+ incr j;
+ let (capture_variables, rhs) = eat_branch ty pat in
+ ((name, Some (ctor_puri !j), capture_variables), rhs))
+ constructors patterns
+ with Invalid_argument _ -> assert false
+ in
+ idref id (Ast.Case (k te, Some case_indty, Some (k ty), patterns))
+ | Cic.AFix (id, no, funs) ->
+ let defs =
+ List.map
+ (fun (_, n, decr_idx, ty, bo) ->
+ ((Ast.Ident (n, None), Some (k ty)), k bo, decr_idx))
+ funs
+ in
+ let name =
+ try
+ (match List.nth defs no with
+ | (Ast.Ident (n, _), _), _, _ when n <> "_" -> n
+ | _ -> assert false)
+ with Not_found -> assert false
+ in
+ idref id (Ast.LetRec (`Inductive, defs, Ast.Ident (name, None)))
+ | Cic.ACoFix (id, no, funs) ->
+ let defs =
+ List.map
+ (fun (_, n, ty, bo) ->
+ ((Ast.Ident (n, None), Some (k ty)), k bo, 0))
+ funs
+ in
+ let name =
+ try
+ (match List.nth defs no with
+ | (Ast.Ident (n, _), _), _, _ when n <> "_" -> n
+ | _ -> assert false)
+ with Not_found -> assert false
+ in
+ idref id (Ast.LetRec (`CoInductive, defs, Ast.Ident (name, None)))
+ in
+ aux acic
+
+ (* persistent state *)
+
+let level2_patterns32 = Hashtbl.create 211
+let interpretations = Hashtbl.create 211 (* symb -> id list ref *)
+
+let compiled32 = ref None
+let pattern32_matrix = ref []
+
+let get_compiled32 () =
+ match !compiled32 with
+ | None -> assert false
+ | Some f -> Lazy.force f
+
+let set_compiled32 f = compiled32 := Some f
+
+let add_idrefs =
+ List.fold_right (fun idref t -> Ast.AttributedTerm (`IdRef idref, t))
+
+let instantiate32 term_info idrefs env symbol args =
+ let rec instantiate_arg = function
+ | Ast.IdentArg (n, name) ->
+ let t = (try List.assoc name env with Not_found -> assert false) in
+ let rec count_lambda = function
+ | Ast.AttributedTerm (_, t) -> count_lambda t
+ | Ast.Binder (`Lambda, _, body) -> 1 + count_lambda body
+ | _ -> 0
+ in
+ let rec add_lambda t n =
+ if n > 0 then
+ let name = CicNotationUtil.fresh_name () in
+ Ast.Binder (`Lambda, (Ast.Ident (name, None), None),
+ Ast.Appl [add_lambda t (n - 1); Ast.Ident (name, None)])
+ else
+ t
+ in
+ add_lambda t (n - count_lambda t)
+ in
+ let head =
+ let symbol = Ast.Symbol (symbol, 0) in
+ add_idrefs idrefs symbol
+ in
+ if args = [] then head
+ else Ast.Appl (head :: List.map instantiate_arg args)
+
+let rec ast_of_acic1 term_info annterm =
+ let id_to_uris = term_info.uri in
+ let register_uri id uri = Hashtbl.add id_to_uris id uri in
+ match (get_compiled32 ()) annterm with
+ | None -> ast_of_acic0 term_info annterm ast_of_acic1
+ | Some (env, ctors, pid) ->
+ let idrefs =
+ List.map
+ (fun annterm ->
+ let idref = CicUtil.id_of_annterm annterm in
+ (try
+ register_uri idref
+ (CicUtil.uri_of_term (Deannotate.deannotate_term annterm))
+ with Invalid_argument _ -> ());
+ idref)
+ ctors
+ in
+ let env' =
+ List.map (fun (name, term) -> (name, ast_of_acic1 term_info term)) env
+ in
+ let _, symbol, args, _ =
+ try
+ Hashtbl.find level2_patterns32 pid
+ with Not_found -> assert false
+ in
+ let ast = instantiate32 term_info idrefs env' symbol args in
+ Ast.AttributedTerm (`IdRef (CicUtil.id_of_annterm annterm), ast)
+
+let load_patterns32 t =
+ let t =
+ HExtlib.filter_map (function (true, ap, id) -> Some (ap, id) | _ -> None) t
+ in
+ set_compiled32 (lazy (Acic2astMatcher.Matcher32.compiler t))
+
+let ast_of_acic id_to_sort annterm =
+ debug_print (lazy ("ast_of_acic <- "
+ ^ CicPp.ppterm (Deannotate.deannotate_term annterm)));
+ let term_info = { sort = id_to_sort; uri = Hashtbl.create 211 } in
+ let ast = ast_of_acic1 term_info annterm in
+ debug_print (lazy ("ast_of_acic -> " ^ CicNotationPp.pp_term ast));
+ ast, term_info.uri
+
+let fresh_id =
+ let counter = ref ~-1 in
+ fun () ->
+ incr counter;
+ !counter
+
+let add_interpretation dsc (symbol, args) appl_pattern =
+ let id = fresh_id () in
+ Hashtbl.add level2_patterns32 id (dsc, symbol, args, appl_pattern);
+ pattern32_matrix := (true, appl_pattern, id) :: !pattern32_matrix;
+ load_patterns32 !pattern32_matrix;
+ (try
+ let ids = Hashtbl.find interpretations symbol in
+ ids := id :: !ids
+ with Not_found -> Hashtbl.add interpretations symbol (ref [id]));
+ id
+
+let get_all_interpretations () =
+ List.map
+ (function (_, _, id) ->
+ let (dsc, _, _, _) =
+ try
+ Hashtbl.find level2_patterns32 id
+ with Not_found -> assert false
+ in
+ (id, dsc))
+ !pattern32_matrix
+
+let get_active_interpretations () =
+ HExtlib.filter_map (function (true, _, id) -> Some id | _ -> None)
+ !pattern32_matrix
+
+let set_active_interpretations ids =
+ let pattern32_matrix' =
+ List.map
+ (function
+ | (_, ap, id) when List.mem id ids -> (true, ap, id)
+ | (_, ap, id) -> (false, ap, id))
+ !pattern32_matrix
+ in
+ pattern32_matrix := pattern32_matrix';
+ load_patterns32 !pattern32_matrix
+
+exception Interpretation_not_found
+
+let lookup_interpretations symbol =
+ try
+ HExtlib.list_uniq
+ (List.sort Pervasives.compare
+ (List.map
+ (fun id ->
+ let (dsc, _, args, appl_pattern) =
+ try
+ Hashtbl.find level2_patterns32 id
+ with Not_found -> assert false
+ in
+ dsc, args, appl_pattern)
+ !(Hashtbl.find interpretations symbol)))
+ with Not_found -> raise Interpretation_not_found
+
+let remove_interpretation id =
+ (try
+ let _, symbol, _, _ = Hashtbl.find level2_patterns32 id in
+ let ids = Hashtbl.find interpretations symbol in
+ ids := List.filter ((<>) id) !ids;
+ Hashtbl.remove level2_patterns32 id;
+ with Not_found -> raise Interpretation_not_found);
+ pattern32_matrix :=
+ List.filter (fun (_, _, id') -> id <> id') !pattern32_matrix;
+ load_patterns32 !pattern32_matrix
+
+let _ = load_patterns32 []
+
+let instantiate_appl_pattern env appl_pattern =
+ let lookup name =
+ try List.assoc name env
+ with Not_found ->
+ prerr_endline (sprintf "Name %s not found" name);
+ assert false
+ in
+ let rec aux = function
+ | Ast.UriPattern uri -> CicUtil.term_of_uri uri
+ | Ast.ImplicitPattern -> Cic.Implicit None
+ | Ast.VarPattern name -> lookup name
+ | Ast.ApplPattern terms -> Cic.Appl (List.map aux terms)
+ in
+ aux appl_pattern
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+ (** {2 Persistant state handling} *)
+
+type interpretation_id
+
+val add_interpretation:
+ string -> (* id / description *)
+ string * CicNotationPt.argument_pattern list -> (* symbol, level 2 pattern *)
+ CicNotationPt.cic_appl_pattern -> (* level 3 pattern *)
+ interpretation_id
+
+ (** @raise Interpretation_not_found *)
+val lookup_interpretations:
+ string -> (* symbol *)
+ (string * CicNotationPt.argument_pattern list *
+ CicNotationPt.cic_appl_pattern) list
+
+exception Interpretation_not_found
+
+ (** @raise Interpretation_not_found *)
+val remove_interpretation: interpretation_id -> unit
+
+ (** {3 Interpretations toggling} *)
+
+val get_all_interpretations: unit -> (interpretation_id * string) list
+val get_active_interpretations: unit -> interpretation_id list
+val set_active_interpretations: interpretation_id list -> unit
+
+ (** {2 acic -> content} *)
+
+val ast_of_acic:
+ (Cic.id, CicNotationPt.sort_kind) Hashtbl.t -> (* id -> sort *)
+ Cic.annterm -> (* acic *)
+ CicNotationPt.term (* ast *)
+ * (Cic.id, UriManager.uri) Hashtbl.t (* id -> uri *)
+
+ (** {2 content -> acic} *)
+
+ (** @param env environment from argument_pattern to cic terms
+ * @param pat cic_appl_pattern *)
+val instantiate_appl_pattern:
+ (string * Cic.term) list -> CicNotationPt.cic_appl_pattern ->
+ Cic.term
+
--- /dev/null
+*.cm[iaox]
+*.cmxa
--- /dev/null
+cic2Xml.cmi: cic2acic.cmi
+eta_fixing.cmo: eta_fixing.cmi
+eta_fixing.cmx: eta_fixing.cmi
+doubleTypeInference.cmo: doubleTypeInference.cmi
+doubleTypeInference.cmx: doubleTypeInference.cmi
+cic2acic.cmo: eta_fixing.cmi doubleTypeInference.cmi cic2acic.cmi
+cic2acic.cmx: eta_fixing.cmx doubleTypeInference.cmx cic2acic.cmi
+cic2Xml.cmo: cic2acic.cmi cic2Xml.cmi
+cic2Xml.cmx: cic2acic.cmx cic2Xml.cmi
--- /dev/null
+PACKAGE = cic_acic
+PREDICATES =
+
+INTERFACE_FILES = \
+ eta_fixing.mli \
+ doubleTypeInference.mli \
+ cic2acic.mli \
+ cic2Xml.mli \
+ $(NULL)
+IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
+
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2000-2004, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(*CSC codice cut & paste da cicPp e xmlcommand *)
+
+exception NotImplemented;;
+
+let dtdname ~ask_dtd_to_the_getter dtd =
+ if ask_dtd_to_the_getter then
+ Helm_registry.get "getter.url" ^ "getdtd?uri=" ^ dtd
+ else
+ "http://mowgli.cs.unibo.it/dtd/" ^ dtd
+;;
+
+let param_attribute_of_params params =
+ String.concat " " (List.map UriManager.string_of_uri params)
+;;
+
+(*CSC ottimizzazione: al posto di curi cdepth (vedi codice) *)
+let print_term ?ids_to_inner_sorts =
+ let find_sort name id =
+ match ids_to_inner_sorts with
+ None -> []
+ | Some ids_to_inner_sorts ->
+ [None,name,Cic2acic.string_of_sort (Hashtbl.find ids_to_inner_sorts id)]
+ in
+ let rec aux =
+ let module C = Cic in
+ let module X = Xml in
+ let module U = UriManager in
+ function
+ C.ARel (id,idref,n,b) ->
+ let sort = find_sort "sort" id in
+ X.xml_empty "REL"
+ (sort @
+ [None,"value",(string_of_int n) ; None,"binder",b ; None,"id",id ;
+ None,"idref",idref])
+ | C.AVar (id,uri,exp_named_subst) ->
+ let sort = find_sort "sort" id in
+ aux_subst uri
+ (X.xml_empty "VAR"
+ (sort @ [None,"uri",U.string_of_uri uri;None,"id",id]))
+ exp_named_subst
+ | C.AMeta (id,n,l) ->
+ let sort = find_sort "sort" id in
+ X.xml_nempty "META"
+ (sort @ [None,"no",(string_of_int n) ; None,"id",id])
+ (List.fold_left
+ (fun i t ->
+ match t with
+ Some t' ->
+ [< i ; X.xml_nempty "substitution" [] (aux t') >]
+ | None ->
+ [< i ; X.xml_empty "substitution" [] >]
+ ) [< >] l)
+ | C.ASort (id,s) ->
+ let string_of_sort s =
+ Cic2acic.string_of_sort (Cic2acic.sort_of_sort s)
+ in
+ X.xml_empty "SORT" [None,"value",(string_of_sort s) ; None,"id",id]
+ | C.AImplicit _ -> raise NotImplemented
+ | C.AProd (last_id,_,_,_) as prods ->
+ let rec eat_prods =
+ function
+ C.AProd (id,n,s,t) ->
+ let prods,t' = eat_prods t in
+ (id,n,s)::prods,t'
+ | t -> [],t
+ in
+ let prods,t = eat_prods prods in
+ let sort = find_sort "type" last_id in
+ X.xml_nempty "PROD" sort
+ [< List.fold_left
+ (fun i (id,binder,s) ->
+ let sort = find_sort "type" (Cic2acic.source_id_of_id id) in
+ let attrs =
+ sort @ ((None,"id",id)::
+ match binder with
+ C.Anonymous -> []
+ | C.Name b -> [None,"binder",b])
+ in
+ [< i ; X.xml_nempty "decl" attrs (aux s) >]
+ ) [< >] prods ;
+ X.xml_nempty "target" [] (aux t)
+ >]
+ | C.ACast (id,v,t) ->
+ let sort = find_sort "sort" id in
+ X.xml_nempty "CAST" (sort @ [None,"id",id])
+ [< X.xml_nempty "term" [] (aux v) ;
+ X.xml_nempty "type" [] (aux t)
+ >]
+ | C.ALambda (last_id,_,_,_) as lambdas ->
+ let rec eat_lambdas =
+ function
+ C.ALambda (id,n,s,t) ->
+ let lambdas,t' = eat_lambdas t in
+ (id,n,s)::lambdas,t'
+ | t -> [],t
+ in
+ let lambdas,t = eat_lambdas lambdas in
+ let sort = find_sort "sort" last_id in
+ X.xml_nempty "LAMBDA" sort
+ [< List.fold_left
+ (fun i (id,binder,s) ->
+ let sort = find_sort "type" (Cic2acic.source_id_of_id id) in
+ let attrs =
+ sort @ ((None,"id",id)::
+ match binder with
+ C.Anonymous -> []
+ | C.Name b -> [None,"binder",b])
+ in
+ [< i ; X.xml_nempty "decl" attrs (aux s) >]
+ ) [< >] lambdas ;
+ X.xml_nempty "target" [] (aux t)
+ >]
+ | C.ALetIn (xid,C.Anonymous,s,t) ->
+ assert false
+ | C.ALetIn (last_id,C.Name _,_,_) as letins ->
+ let rec eat_letins =
+ function
+ C.ALetIn (id,n,s,t) ->
+ let letins,t' = eat_letins t in
+ (id,n,s)::letins,t'
+ | t -> [],t
+ in
+ let letins,t = eat_letins letins in
+ let sort = find_sort "sort" last_id in
+ X.xml_nempty "LETIN" sort
+ [< List.fold_left
+ (fun i (id,binder,s) ->
+ let sort = find_sort "sort" id in
+ let attrs =
+ sort @ ((None,"id",id)::
+ match binder with
+ C.Anonymous -> []
+ | C.Name b -> [None,"binder",b])
+ in
+ [< i ; X.xml_nempty "def" attrs (aux s) >]
+ ) [< >] letins ;
+ X.xml_nempty "target" [] (aux t)
+ >]
+ | C.AAppl (id,li) ->
+ let sort = find_sort "sort" id in
+ X.xml_nempty "APPLY" (sort @ [None,"id",id])
+ [< (List.fold_right (fun x i -> [< (aux x) ; i >]) li [<>])
+ >]
+ | C.AConst (id,uri,exp_named_subst) ->
+ let sort = find_sort "sort" id in
+ aux_subst uri
+ (X.xml_empty "CONST"
+ (sort @ [None,"uri",(U.string_of_uri uri) ; None,"id",id])
+ ) exp_named_subst
+ | C.AMutInd (id,uri,i,exp_named_subst) ->
+ aux_subst uri
+ (X.xml_empty "MUTIND"
+ [None, "uri", (U.string_of_uri uri) ;
+ None, "noType", (string_of_int i) ;
+ None, "id", id]
+ ) exp_named_subst
+ | C.AMutConstruct (id,uri,i,j,exp_named_subst) ->
+ let sort = find_sort "sort" id in
+ aux_subst uri
+ (X.xml_empty "MUTCONSTRUCT"
+ (sort @
+ [None,"uri", (U.string_of_uri uri) ;
+ None,"noType",(string_of_int i) ;
+ None,"noConstr",(string_of_int j) ;
+ None,"id",id])
+ ) exp_named_subst
+ | C.AMutCase (id,uri,typeno,ty,te,patterns) ->
+ let sort = find_sort "sort" id in
+ X.xml_nempty "MUTCASE"
+ (sort @
+ [None,"uriType",(U.string_of_uri uri) ;
+ None,"noType", (string_of_int typeno) ;
+ None,"id", id])
+ [< X.xml_nempty "patternsType" [] [< (aux ty) >] ;
+ X.xml_nempty "inductiveTerm" [] [< (aux te) >] ;
+ List.fold_right
+ (fun x i -> [< X.xml_nempty "pattern" [] [< aux x >] ; i>])
+ patterns [<>]
+ >]
+ | C.AFix (id, no, funs) ->
+ let sort = find_sort "sort" id in
+ X.xml_nempty "FIX"
+ (sort @ [None,"noFun", (string_of_int no) ; None,"id",id])
+ [< List.fold_right
+ (fun (id,fi,ai,ti,bi) i ->
+ [< X.xml_nempty "FixFunction"
+ [None,"id",id ; None,"name", fi ;
+ None,"recIndex", (string_of_int ai)]
+ [< X.xml_nempty "type" [] [< aux ti >] ;
+ X.xml_nempty "body" [] [< aux bi >]
+ >] ;
+ i
+ >]
+ ) funs [<>]
+ >]
+ | C.ACoFix (id,no,funs) ->
+ let sort = find_sort "sort" id in
+ X.xml_nempty "COFIX"
+ (sort @ [None,"noFun", (string_of_int no) ; None,"id",id])
+ [< List.fold_right
+ (fun (id,fi,ti,bi) i ->
+ [< X.xml_nempty "CofixFunction" [None,"id",id ; None,"name", fi]
+ [< X.xml_nempty "type" [] [< aux ti >] ;
+ X.xml_nempty "body" [] [< aux bi >]
+ >] ;
+ i
+ >]
+ ) funs [<>]
+ >]
+ and aux_subst buri target subst =
+(*CSC: I have now no way to assign an ID to the explicit named substitution *)
+ let id = None in
+ if subst = [] then
+ target
+ else
+ Xml.xml_nempty "instantiate"
+ (match id with None -> [] | Some id -> [None,"id",id])
+ [< target ;
+ List.fold_left
+ (fun i (uri,arg) ->
+ let relUri =
+ let buri_frags =
+ Str.split (Str.regexp "/") (UriManager.string_of_uri buri) in
+ let uri_frags =
+ Str.split (Str.regexp "/") (UriManager.string_of_uri uri) in
+ let rec find_relUri buri_frags uri_frags =
+ match buri_frags,uri_frags with
+ [_], _ -> String.concat "/" uri_frags
+ | he1::tl1, he2::tl2 ->
+ assert (he1 = he2) ;
+ find_relUri tl1 tl2
+ | _,_ -> assert false (* uri is not relative to buri *)
+ in
+ find_relUri buri_frags uri_frags
+ in
+ [< i ; Xml.xml_nempty "arg" [None,"relUri", relUri] (aux arg) >]
+ ) [<>] subst
+ >]
+ in
+ aux
+;;
+
+let xml_of_attrs attributes =
+ let class_of = function
+ | `Coercion -> Xml.xml_empty "class" [None,"value","coercion"]
+ | `Elim s ->
+ Xml.xml_nempty "class" [None,"value","elim"]
+ [< Xml.xml_empty
+ "SORT" [None,"value",
+ (Cic2acic.string_of_sort (Cic2acic.sort_of_sort s)) ;
+ None,"id","elimination_sort"] >]
+ | `Record field_names ->
+ Xml.xml_nempty "class" [None,"value","record"]
+ (List.fold_right
+ (fun name res ->
+ [< Xml.xml_empty "field" [None,"name",name]; res >]
+ ) field_names [<>])
+ | `Projection -> Xml.xml_empty "class" [None,"value","projection"]
+ in
+ let flavour_of = function
+ | `Definition -> Xml.xml_empty "flavour" [None, "value", "definition"]
+ | `Fact -> Xml.xml_empty "flavour" [None, "value", "fact"]
+ | `Lemma -> Xml.xml_empty "flavour" [None, "value", "lemma"]
+ | `Remark -> Xml.xml_empty "flavour" [None, "value", "remark"]
+ | `Theorem -> Xml.xml_empty "flavour" [None, "value", "theorem"]
+ | `Variant -> Xml.xml_empty "flavour" [None, "value", "variant"]
+ in
+ let xml_attr_of = function
+ | `Generated -> Xml.xml_empty "generated" []
+ | `Class c -> class_of c
+ | `Flavour f -> flavour_of f
+ in
+ let xml_attrs =
+ List.fold_right
+ (fun attr res -> [< xml_attr_of attr ; res >]) attributes [<>]
+ in
+ Xml.xml_nempty "attributes" [] xml_attrs
+
+let print_object uri ?ids_to_inner_sorts ~ask_dtd_to_the_getter obj =
+ let module C = Cic in
+ let module X = Xml in
+ let module U = UriManager in
+ let dtdname = dtdname ~ask_dtd_to_the_getter "cic.dtd" in
+ match obj with
+ C.ACurrentProof (id,idbody,n,conjectures,bo,ty,params,obj_attrs) ->
+ let params' = param_attribute_of_params params in
+ let xml_attrs = xml_of_attrs obj_attrs in
+ let xml_for_current_proof_body =
+(*CSC: Should the CurrentProof also have the list of variables it depends on? *)
+(*CSC: I think so. Not implemented yet. *)
+ X.xml_nempty "CurrentProof"
+ [None,"of",UriManager.string_of_uri uri ; None,"id", id]
+ [< xml_attrs;
+ List.fold_left
+ (fun i (cid,n,canonical_context,t) ->
+ [< i ;
+ X.xml_nempty "Conjecture"
+ [None,"id",cid ; None,"no",(string_of_int n)]
+ [< List.fold_left
+ (fun i (hid,t) ->
+ [< (match t with
+ Some (n,C.ADecl t) ->
+ X.xml_nempty "Decl"
+ (match n with
+ C.Name n' ->
+ [None,"id",hid;None,"name",n']
+ | C.Anonymous -> [None,"id",hid])
+ (print_term ?ids_to_inner_sorts t)
+ | Some (n,C.ADef t) ->
+ X.xml_nempty "Def"
+ (match n with
+ C.Name n' ->
+ [None,"id",hid;None,"name",n']
+ | C.Anonymous -> [None,"id",hid])
+ (print_term ?ids_to_inner_sorts t)
+ | None -> X.xml_empty "Hidden" [None,"id",hid]
+ ) ;
+ i
+ >]
+ ) [< >] canonical_context ;
+ X.xml_nempty "Goal" []
+ (print_term ?ids_to_inner_sorts t)
+ >]
+ >])
+ [< >] conjectures ;
+ X.xml_nempty "body" [] (print_term ?ids_to_inner_sorts bo) >]
+ in
+ let xml_for_current_proof_type =
+ X.xml_nempty "ConstantType"
+ [None,"name",n ; None,"params",params' ; None,"id", id]
+ (print_term ?ids_to_inner_sorts ty)
+ in
+ let xmlbo =
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE CurrentProof SYSTEM \""^ dtdname ^ "\">\n");
+ xml_for_current_proof_body
+ >] in
+ let xmlty =
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^ dtdname ^ "\">\n");
+ xml_for_current_proof_type
+ >]
+ in
+ xmlty, Some xmlbo
+ | C.AConstant (id,idbody,n,bo,ty,params,obj_attrs) ->
+ let params' = param_attribute_of_params params in
+ let xml_attrs = xml_of_attrs obj_attrs in
+ let xmlbo =
+ match bo with
+ None -> None
+ | Some bo ->
+ Some
+ [< X.xml_cdata
+ "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata
+ ("<!DOCTYPE ConstantBody SYSTEM \"" ^ dtdname ^ "\">\n") ;
+ X.xml_nempty "ConstantBody"
+ [None,"for",UriManager.string_of_uri uri ;
+ None,"params",params' ; None,"id", id]
+ [< print_term ?ids_to_inner_sorts bo >]
+ >]
+ in
+ let xmlty =
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^ dtdname ^ "\">\n");
+ X.xml_nempty "ConstantType"
+ [None,"name",n ; None,"params",params' ; None,"id", id]
+ [< xml_attrs; print_term ?ids_to_inner_sorts ty >]
+ >]
+ in
+ xmlty, xmlbo
+ | C.AVariable (id,n,bo,ty,params,obj_attrs) ->
+ let params' = param_attribute_of_params params in
+ let xml_attrs = xml_of_attrs obj_attrs in
+ let xmlbo =
+ match bo with
+ None -> [< >]
+ | Some bo ->
+ X.xml_nempty "body" [] [< print_term ?ids_to_inner_sorts bo >]
+ in
+ let aobj =
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE Variable SYSTEM \"" ^ dtdname ^ "\">\n");
+ X.xml_nempty "Variable"
+ [None,"name",n ; None,"params",params' ; None,"id", id]
+ [< xml_attrs; xmlbo;
+ X.xml_nempty "type" [] (print_term ?ids_to_inner_sorts ty)
+ >]
+ >]
+ in
+ aobj, None
+ | C.AInductiveDefinition (id,tys,params,nparams,obj_attrs) ->
+ let params' = param_attribute_of_params params in
+ let xml_attrs = xml_of_attrs obj_attrs in
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata
+ ("<!DOCTYPE InductiveDefinition SYSTEM \"" ^ dtdname ^ "\">\n") ;
+ X.xml_nempty "InductiveDefinition"
+ [None,"noParams",string_of_int nparams ;
+ None,"id",id ;
+ None,"params",params']
+ [< xml_attrs;
+ (List.fold_left
+ (fun i (id,typename,finite,arity,cons) ->
+ [< i ;
+ X.xml_nempty "InductiveType"
+ [None,"id",id ; None,"name",typename ;
+ None,"inductive",(string_of_bool finite)
+ ]
+ [< X.xml_nempty "arity" []
+ (print_term ?ids_to_inner_sorts arity) ;
+ (List.fold_left
+ (fun i (name,lc) ->
+ [< i ;
+ X.xml_nempty "Constructor"
+ [None,"name",name]
+ (print_term ?ids_to_inner_sorts lc)
+ >]) [<>] cons
+ )
+ >]
+ >]
+ ) [< >] tys
+ )
+ >]
+ >], None
+;;
+
+let
+ print_inner_types curi ~ids_to_inner_sorts ~ids_to_inner_types
+ ~ask_dtd_to_the_getter
+=
+ let module C2A = Cic2acic in
+ let module X = Xml in
+ let dtdname = dtdname ~ask_dtd_to_the_getter "cictypes.dtd" in
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata
+ ("<!DOCTYPE InnerTypes SYSTEM \"" ^ dtdname ^ "\">\n") ;
+ X.xml_nempty "InnerTypes" [None,"of",UriManager.string_of_uri curi]
+ (Hashtbl.fold
+ (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x ->
+ [< x ;
+ X.xml_nempty "TYPE" [None,"of",id]
+ [< X.xml_nempty "synthesized" []
+ [< print_term ~ids_to_inner_sorts synty >] ;
+ match expty with
+ None -> [<>]
+ | Some expty' -> X.xml_nempty "expected" []
+ [< print_term ~ids_to_inner_sorts expty' >]
+ >]
+ >]
+ ) ids_to_inner_types [<>]
+ )
+ >]
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception NotImplemented
+
+val print_term :
+ ?ids_to_inner_sorts: (string, Cic2acic.sort_kind) Hashtbl.t ->
+ Cic.annterm ->
+ Xml.token Stream.t
+
+val print_object :
+ UriManager.uri ->
+ ?ids_to_inner_sorts: (string, Cic2acic.sort_kind) Hashtbl.t ->
+ ask_dtd_to_the_getter:bool ->
+ Cic.annobj ->
+ Xml.token Stream.t * Xml.token Stream.t option
+
+val print_inner_types :
+ UriManager.uri ->
+ ids_to_inner_sorts: (string, Cic2acic.sort_kind) Hashtbl.t ->
+ ids_to_inner_types: (string, Cic2acic.anntypes) Hashtbl.t ->
+ ask_dtd_to_the_getter:bool ->
+ Xml.token Stream.t
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+type sort_kind = [ `Prop | `Set | `Type of CicUniv.universe | `CProp ]
+
+let string_of_sort = function
+ | `Prop -> "Prop"
+ | `Set -> "Set"
+ | `Type u -> "Type:" ^ string_of_int (CicUniv.univno u)
+ | `CProp -> "CProp"
+
+let sort_of_sort = function
+ | Cic.Prop -> `Prop
+ | Cic.Set -> `Set
+ | Cic.Type u -> `Type u
+ | Cic.CProp -> `CProp
+
+(* let hashtbl_add_time = ref 0.0;; *)
+
+let xxx_add h k v =
+(* let t1 = Sys.time () in *)
+ Hashtbl.add h k v ;
+(* let t2 = Sys.time () in
+ hashtbl_add_time := !hashtbl_add_time +. t2 -. t1 *)
+;;
+
+(* let number_new_type_of_aux' = ref 0;;
+let type_of_aux'_add_time = ref 0.0;; *)
+
+let xxx_type_of_aux' m c t =
+(* let t1 = Sys.time () in *)
+ let res,_ =
+ try
+ CicTypeChecker.type_of_aux' m c t CicUniv.empty_ugraph
+ with
+ | CicTypeChecker.AssertFailure _
+ | CicTypeChecker.TypeCheckerFailure _ ->
+ Cic.Sort Cic.Prop, CicUniv.empty_ugraph
+ in
+(* let t2 = Sys.time () in
+ type_of_aux'_add_time := !type_of_aux'_add_time +. t2 -. t1 ; *)
+ res
+;;
+
+type anntypes =
+ {annsynthesized : Cic.annterm ; annexpected : Cic.annterm option}
+;;
+
+let gen_id seed =
+ let res = "i" ^ string_of_int !seed in
+ incr seed ;
+ res
+;;
+
+let fresh_id seed ids_to_terms ids_to_father_ids =
+ fun father t ->
+ let res = gen_id seed in
+ xxx_add ids_to_father_ids res father ;
+ xxx_add ids_to_terms res t ;
+ res
+;;
+
+let source_id_of_id id = "#source#" ^ id;;
+
+exception NotEnoughElements;;
+
+(*CSC: cut&paste da cicPp.ml *)
+(* get_nth l n returns the nth element of the list l if it exists or *)
+(* raises NotEnoughElements if l has less than n elements *)
+let rec get_nth l n =
+ match (n,l) with
+ (1, he::_) -> he
+ | (n, he::tail) when n > 1 -> get_nth tail (n-1)
+ | (_,_) -> raise NotEnoughElements
+;;
+
+let acic_of_cic_context' ~computeinnertypes:global_computeinnertypes
+ seed ids_to_terms ids_to_father_ids ids_to_inner_sorts ids_to_inner_types
+ metasenv context idrefs t expectedty
+=
+ let module D = DoubleTypeInference in
+ let module C = Cic in
+ let fresh_id' = fresh_id seed ids_to_terms ids_to_father_ids in
+(* let time1 = Sys.time () in *)
+ let terms_to_types =
+(*
+ let time0 = Sys.time () in
+ let prova = CicTypeChecker.type_of_aux' metasenv context t in
+ let time1 = Sys.time () in
+ prerr_endline ("*** Fine type_inference:" ^ (string_of_float (time1 -. time0)));
+ let res = D.double_type_of metasenv context t expectedty in
+ let time2 = Sys.time () in
+ prerr_endline ("*** Fine double_type_inference:" ^ (string_of_float (time2 -. time1)));
+ res
+*)
+ if global_computeinnertypes then
+ D.double_type_of metasenv context t expectedty
+ else
+ D.CicHash.empty ()
+ in
+(*
+ let time2 = Sys.time () in
+ prerr_endline
+ ("++++++++++++ Tempi della double_type_of: "^ string_of_float (time2 -. time1)) ;
+*)
+ let rec aux computeinnertypes father context idrefs tt =
+ let fresh_id'' = fresh_id' father tt in
+ (*CSC: computeinnertypes era true, il che e' proprio sbagliato, no? *)
+ let aux' = aux computeinnertypes (Some fresh_id'') in
+ (* First of all we compute the inner type and the inner sort *)
+ (* of the term. They may be useful in what follows. *)
+ (*CSC: This is a very inefficient way of computing inner types *)
+ (*CSC: and inner sorts: very deep terms have their types/sorts *)
+ (*CSC: computed again and again. *)
+ let sort_of t =
+ match CicReduction.whd context t with
+ C.Sort C.Prop -> `Prop
+ | C.Sort C.Set -> `Set
+ | C.Sort (C.Type u) -> `Type u
+ | C.Meta _ -> `Type (CicUniv.fresh())
+ | C.Sort C.CProp -> `CProp
+ | t ->
+ prerr_endline ("Cic2acic.sort_of applied to: " ^ CicPp.ppterm t) ;
+ assert false
+ in
+ let ainnertypes,innertype,innersort,expected_available =
+(*CSC: Here we need the algorithm for Coscoy's double type-inference *)
+(*CSC: (expected type + inferred type). Just for now we use the usual *)
+(*CSC: type-inference, but the result is very poor. As a very weak *)
+(*CSC: patch, I apply whd to the computed type. Full beta *)
+(*CSC: reduction would be a much better option. *)
+(*CSC: solo per testare i tempi *)
+(*XXXXXXX *)
+ try
+(* *)
+ let {D.synthesized = synthesized; D.expected = expected} =
+ if computeinnertypes then
+ D.CicHash.find terms_to_types tt
+ else
+ (* We are already in an inner-type and Coscoy's double *)
+ (* type inference algorithm has not been applied. *)
+ { D.synthesized =
+(***CSC: patch per provare i tempi
+ CicReduction.whd context (xxx_type_of_aux' metasenv context tt) ; *)
+ if global_computeinnertypes then
+ Cic.Sort (Cic.Type (CicUniv.fresh()))
+ else
+ CicReduction.whd context (xxx_type_of_aux' metasenv context tt);
+ D.expected = None}
+ in
+(* incr number_new_type_of_aux' ; *)
+ let innersort = (*XXXXX *) xxx_type_of_aux' metasenv context synthesized (* Cic.Sort Cic.Prop *) in
+ let ainnertypes,expected_available =
+ if computeinnertypes then
+ let annexpected,expected_available =
+ match expected with
+ None -> None,false
+ | Some expectedty' ->
+ Some
+ (aux false (Some fresh_id'') context idrefs expectedty'),
+ true
+ in
+ Some
+ {annsynthesized =
+ aux false (Some fresh_id'') context idrefs synthesized ;
+ annexpected = annexpected
+ }, expected_available
+ else
+ None,false
+ in
+ ainnertypes,synthesized, sort_of innersort, expected_available
+(*XXXXXXXX *)
+ with
+ Not_found -> (* l'inner-type non e' nella tabella ==> sort <> Prop *)
+ (* CSC: Type or Set? I can not tell *)
+ let u = CicUniv.fresh() in
+ None,Cic.Sort (Cic.Type u),`Type u,false
+ (* TASSI non dovrebbe fare danni *)
+(* *)
+ in
+ let add_inner_type id =
+ match ainnertypes with
+ None -> ()
+ | Some ainnertypes -> xxx_add ids_to_inner_types id ainnertypes
+ in
+ match tt with
+ C.Rel n ->
+ let id =
+ match get_nth context n with
+ (Some (C.Name s,_)) -> s
+ | _ -> "__" ^ string_of_int n
+ in
+ xxx_add ids_to_inner_sorts fresh_id'' innersort ;
+ if innersort = `Prop && expected_available then
+ add_inner_type fresh_id'' ;
+ C.ARel (fresh_id'', List.nth idrefs (n-1), n, id)
+ | C.Var (uri,exp_named_subst) ->
+ xxx_add ids_to_inner_sorts fresh_id'' innersort ;
+ if innersort = `Prop && expected_available then
+ add_inner_type fresh_id'' ;
+ let exp_named_subst' =
+ List.map
+ (function i,t -> i, (aux' context idrefs t)) exp_named_subst
+ in
+ C.AVar (fresh_id'', uri,exp_named_subst')
+ | C.Meta (n,l) ->
+ let (_,canonical_context,_) = CicUtil.lookup_meta n metasenv in
+ xxx_add ids_to_inner_sorts fresh_id'' innersort ;
+ if innersort = `Prop && expected_available then
+ add_inner_type fresh_id'' ;
+ C.AMeta (fresh_id'', n,
+ (List.map2
+ (fun ct t ->
+ match (ct, t) with
+ | None, _ -> None
+ | _, Some t -> Some (aux' context idrefs t)
+ | Some _, None -> assert false (* due to typing rules *))
+ canonical_context l))
+ | C.Sort s -> C.ASort (fresh_id'', s)
+ | C.Implicit annotation -> C.AImplicit (fresh_id'', annotation)
+ | C.Cast (v,t) ->
+ xxx_add ids_to_inner_sorts fresh_id'' innersort ;
+ if innersort = `Prop then
+ add_inner_type fresh_id'' ;
+ C.ACast (fresh_id'', aux' context idrefs v, aux' context idrefs t)
+ | C.Prod (n,s,t) ->
+ xxx_add ids_to_inner_sorts fresh_id''
+ (sort_of innertype) ;
+ let sourcetype = xxx_type_of_aux' metasenv context s in
+ xxx_add ids_to_inner_sorts (source_id_of_id fresh_id'')
+ (sort_of sourcetype) ;
+ let n' =
+ match n with
+ C.Anonymous -> n
+ | C.Name n' ->
+ if DoubleTypeInference.does_not_occur 1 t then
+ C.Anonymous
+ else
+ C.Name n'
+ in
+ C.AProd
+ (fresh_id'', n', aux' context idrefs s,
+ aux' ((Some (n, C.Decl s))::context) (fresh_id''::idrefs) t)
+ | C.Lambda (n,s,t) ->
+ xxx_add ids_to_inner_sorts fresh_id'' innersort ;
+ let sourcetype = xxx_type_of_aux' metasenv context s in
+ xxx_add ids_to_inner_sorts (source_id_of_id fresh_id'')
+ (sort_of sourcetype) ;
+ if innersort = `Prop then
+ begin
+ let father_is_lambda =
+ match father with
+ None -> false
+ | Some father' ->
+ match Hashtbl.find ids_to_terms father' with
+ C.Lambda _ -> true
+ | _ -> false
+ in
+ if (not father_is_lambda) || expected_available then
+ add_inner_type fresh_id''
+ end ;
+ C.ALambda
+ (fresh_id'',n, aux' context idrefs s,
+ aux' ((Some (n, C.Decl s)::context)) (fresh_id''::idrefs) t)
+ | C.LetIn (n,s,t) ->
+ xxx_add ids_to_inner_sorts fresh_id'' innersort ;
+ if innersort = `Prop then
+ add_inner_type fresh_id'' ;
+ C.ALetIn
+ (fresh_id'', n, aux' context idrefs s,
+ aux' ((Some (n, C.Def(s,None)))::context) (fresh_id''::idrefs) t)
+ | C.Appl l ->
+ xxx_add ids_to_inner_sorts fresh_id'' innersort ;
+ if innersort = `Prop then
+ add_inner_type fresh_id'' ;
+ C.AAppl (fresh_id'', List.map (aux' context idrefs) l)
+ | C.Const (uri,exp_named_subst) ->
+ xxx_add ids_to_inner_sorts fresh_id'' innersort ;
+ if innersort = `Prop && expected_available then
+ add_inner_type fresh_id'' ;
+ let exp_named_subst' =
+ List.map
+ (function i,t -> i, (aux' context idrefs t)) exp_named_subst
+ in
+ C.AConst (fresh_id'', uri, exp_named_subst')
+ | C.MutInd (uri,tyno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map
+ (function i,t -> i, (aux' context idrefs t)) exp_named_subst
+ in
+ C.AMutInd (fresh_id'', uri, tyno, exp_named_subst')
+ | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
+ xxx_add ids_to_inner_sorts fresh_id'' innersort ;
+ if innersort = `Prop && expected_available then
+ add_inner_type fresh_id'' ;
+ let exp_named_subst' =
+ List.map
+ (function i,t -> i, (aux' context idrefs t)) exp_named_subst
+ in
+ C.AMutConstruct (fresh_id'', uri, tyno, consno, exp_named_subst')
+ | C.MutCase (uri, tyno, outty, term, patterns) ->
+ xxx_add ids_to_inner_sorts fresh_id'' innersort ;
+ if innersort = `Prop then
+ add_inner_type fresh_id'' ;
+ C.AMutCase (fresh_id'', uri, tyno, aux' context idrefs outty,
+ aux' context idrefs term, List.map (aux' context idrefs) patterns)
+ | C.Fix (funno, funs) ->
+ let fresh_idrefs =
+ List.map (function _ -> gen_id seed) funs in
+ let new_idrefs = List.rev fresh_idrefs @ idrefs in
+ let tys =
+ List.map (fun (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) funs
+ in
+ xxx_add ids_to_inner_sorts fresh_id'' innersort ;
+ if innersort = `Prop then
+ add_inner_type fresh_id'' ;
+ C.AFix (fresh_id'', funno,
+ List.map2
+ (fun id (name, indidx, ty, bo) ->
+ (id, name, indidx, aux' context idrefs ty,
+ aux' (tys@context) new_idrefs bo)
+ ) fresh_idrefs funs
+ )
+ | C.CoFix (funno, funs) ->
+ let fresh_idrefs =
+ List.map (function _ -> gen_id seed) funs in
+ let new_idrefs = List.rev fresh_idrefs @ idrefs in
+ let tys =
+ List.map (fun (name,ty,_) -> Some (C.Name name, C.Decl ty)) funs
+ in
+ xxx_add ids_to_inner_sorts fresh_id'' innersort ;
+ if innersort = `Prop then
+ add_inner_type fresh_id'' ;
+ C.ACoFix (fresh_id'', funno,
+ List.map2
+ (fun id (name, ty, bo) ->
+ (id, name, aux' context idrefs ty,
+ aux' (tys@context) new_idrefs bo)
+ ) fresh_idrefs funs
+ )
+ in
+(*
+ let timea = Sys.time () in
+ let res = aux true None context idrefs t in
+ let timeb = Sys.time () in
+ prerr_endline
+ ("+++++++++++++ Tempi della aux dentro alla acic_of_cic: "^ string_of_float (timeb -. timea)) ;
+ res
+*)
+ aux global_computeinnertypes None context idrefs t
+;;
+
+let acic_of_cic_context ~computeinnertypes metasenv context idrefs t =
+ let ids_to_terms = Hashtbl.create 503 in
+ let ids_to_father_ids = Hashtbl.create 503 in
+ let ids_to_inner_sorts = Hashtbl.create 503 in
+ let ids_to_inner_types = Hashtbl.create 503 in
+ let seed = ref 0 in
+ acic_of_cic_context' ~computeinnertypes seed ids_to_terms ids_to_father_ids ids_to_inner_sorts
+ ids_to_inner_types metasenv context idrefs t,
+ ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types
+;;
+
+let aconjecture_of_conjecture seed ids_to_terms ids_to_father_ids
+ ids_to_inner_sorts ids_to_inner_types ids_to_hypotheses hypotheses_seed
+ metasenv (metano,context,goal)
+=
+ let computeinnertypes = false in
+ let acic_of_cic_context =
+ acic_of_cic_context' seed ids_to_terms ids_to_father_ids ids_to_inner_sorts
+ ids_to_inner_types metasenv in
+ let _, acontext,final_idrefs =
+ (List.fold_right
+ (fun binding (context, acontext,idrefs) ->
+ let hid = "h" ^ string_of_int !hypotheses_seed in
+ Hashtbl.add ids_to_hypotheses hid binding ;
+ incr hypotheses_seed ;
+ match binding with
+ Some (n,Cic.Def (t,_)) ->
+ let acic = acic_of_cic_context ~computeinnertypes context idrefs t None in
+ (binding::context),
+ ((hid,Some (n,Cic.ADef acic))::acontext),(hid::idrefs)
+ | Some (n,Cic.Decl t) ->
+ let acic = acic_of_cic_context ~computeinnertypes context idrefs t None in
+ (binding::context),
+ ((hid,Some (n,Cic.ADecl acic))::acontext),(hid::idrefs)
+ | None ->
+ (* Invariant: "" is never looked up *)
+ (None::context),((hid,None)::acontext),""::idrefs
+ ) context ([],[],[])
+ )
+ in
+ let agoal = acic_of_cic_context ~computeinnertypes context final_idrefs goal None in
+ (metano,acontext,agoal)
+;;
+
+let asequent_of_sequent (metasenv:Cic.metasenv) (sequent:Cic.conjecture) =
+ let ids_to_terms = Hashtbl.create 503 in
+ let ids_to_father_ids = Hashtbl.create 503 in
+ let ids_to_inner_sorts = Hashtbl.create 503 in
+ let ids_to_inner_types = Hashtbl.create 503 in
+ let ids_to_hypotheses = Hashtbl.create 23 in
+ let hypotheses_seed = ref 0 in
+ let seed = ref 1 in (* 'i0' is used for the whole sequent *)
+ let unsh_sequent =
+ let i,canonical_context,term = sequent in
+ let canonical_context' =
+ List.fold_right
+ (fun d canonical_context' ->
+ let d =
+ match d with
+ None -> None
+ | Some (n, Cic.Decl t)->
+ Some (n, Cic.Decl (Unshare.unshare t))
+ | Some (n, Cic.Def (t,None)) ->
+ Some (n, Cic.Def ((Unshare.unshare t),None))
+ | Some (n,Cic.Def (bo,Some ty)) ->
+ Some (n, Cic.Def (Unshare.unshare bo,Some (Unshare.unshare ty)))
+ in
+ d::canonical_context'
+ ) canonical_context []
+ in
+ let term' = Unshare.unshare term in
+ (i,canonical_context',term')
+ in
+ let (metano,acontext,agoal) =
+ aconjecture_of_conjecture seed ids_to_terms ids_to_father_ids
+ ids_to_inner_sorts ids_to_inner_types ids_to_hypotheses hypotheses_seed
+ metasenv unsh_sequent in
+ (unsh_sequent,
+ (("i0",metano,acontext,agoal),
+ ids_to_terms,ids_to_father_ids,ids_to_inner_sorts,ids_to_hypotheses))
+;;
+
+let acic_object_of_cic_object ?(eta_fix=true) obj =
+ let module C = Cic in
+ let module E = Eta_fixing in
+ let ids_to_terms = Hashtbl.create 503 in
+ let ids_to_father_ids = Hashtbl.create 503 in
+ let ids_to_inner_sorts = Hashtbl.create 503 in
+ let ids_to_inner_types = Hashtbl.create 503 in
+ let ids_to_conjectures = Hashtbl.create 11 in
+ let ids_to_hypotheses = Hashtbl.create 127 in
+ let hypotheses_seed = ref 0 in
+ let conjectures_seed = ref 0 in
+ let seed = ref 0 in
+ let acic_term_of_cic_term_context' =
+ acic_of_cic_context' seed ids_to_terms ids_to_father_ids ids_to_inner_sorts
+ ids_to_inner_types in
+ let acic_term_of_cic_term' = acic_term_of_cic_term_context' [] [] [] in
+ let aconjecture_of_conjecture' = aconjecture_of_conjecture seed
+ ids_to_terms ids_to_father_ids ids_to_inner_sorts ids_to_inner_types
+ ids_to_hypotheses hypotheses_seed in
+ let eta_fix metasenv context t =
+ let t = if eta_fix then E.eta_fix metasenv context t else t in
+ Unshare.unshare t in
+ let aobj =
+ match obj with
+ C.Constant (id,Some bo,ty,params,attrs) ->
+ let bo' = eta_fix [] [] bo in
+ let ty' = eta_fix [] [] ty in
+ let abo = acic_term_of_cic_term' ~computeinnertypes:true bo' (Some ty') in
+ let aty = acic_term_of_cic_term' ~computeinnertypes:false ty' None in
+ C.AConstant
+ ("mettereaposto",Some "mettereaposto2",id,Some abo,aty,params,attrs)
+ | C.Constant (id,None,ty,params,attrs) ->
+ let ty' = eta_fix [] [] ty in
+ let aty = acic_term_of_cic_term' ~computeinnertypes:false ty' None in
+ C.AConstant
+ ("mettereaposto",None,id,None,aty,params,attrs)
+ | C.Variable (id,bo,ty,params,attrs) ->
+ let ty' = eta_fix [] [] ty in
+ let abo =
+ match bo with
+ None -> None
+ | Some bo ->
+ let bo' = eta_fix [] [] bo in
+ Some (acic_term_of_cic_term' ~computeinnertypes:true bo' (Some ty'))
+ in
+ let aty = acic_term_of_cic_term' ~computeinnertypes:false ty' None in
+ C.AVariable
+ ("mettereaposto",id,abo,aty,params,attrs)
+ | C.CurrentProof (id,conjectures,bo,ty,params,attrs) ->
+ let conjectures' =
+ List.map
+ (function (i,canonical_context,term) ->
+ let canonical_context' =
+ List.fold_right
+ (fun d canonical_context' ->
+ let d =
+ match d with
+ None -> None
+ | Some (n, C.Decl t)->
+ Some (n, C.Decl (eta_fix conjectures canonical_context' t))
+ | Some (n, C.Def (t,None)) ->
+ Some (n,
+ C.Def ((eta_fix conjectures canonical_context' t),None))
+ | Some (_,C.Def (_,Some _)) -> assert false
+ in
+ d::canonical_context'
+ ) canonical_context []
+ in
+ let term' = eta_fix conjectures canonical_context' term in
+ (i,canonical_context',term')
+ ) conjectures
+ in
+ let aconjectures =
+ List.map
+ (function (i,canonical_context,term) as conjecture ->
+ let cid = "c" ^ string_of_int !conjectures_seed in
+ xxx_add ids_to_conjectures cid conjecture ;
+ incr conjectures_seed ;
+ let (i,acanonical_context,aterm)
+ = aconjecture_of_conjecture' conjectures conjecture in
+ (cid,i,acanonical_context,aterm))
+ conjectures' in
+(* let time1 = Sys.time () in *)
+ let bo' = eta_fix conjectures' [] bo in
+ let ty' = eta_fix conjectures' [] ty in
+(*
+ let time2 = Sys.time () in
+ prerr_endline
+ ("++++++++++ Tempi della eta_fix: "^ string_of_float (time2 -. time1)) ;
+ hashtbl_add_time := 0.0 ;
+ type_of_aux'_add_time := 0.0 ;
+ DoubleTypeInference.syntactic_equality_add_time := 0.0 ;
+*)
+ let abo =
+ acic_term_of_cic_term_context' ~computeinnertypes:true conjectures' [] [] bo' (Some ty') in
+ let aty = acic_term_of_cic_term_context' ~computeinnertypes:false conjectures' [] [] ty' None in
+(*
+ let time3 = Sys.time () in
+ prerr_endline
+ ("++++++++++++ Tempi della hashtbl_add_time: " ^ string_of_float !hashtbl_add_time) ;
+ prerr_endline
+ ("++++++++++++ Tempi della type_of_aux'_add_time(" ^ string_of_int !number_new_type_of_aux' ^ "): " ^ string_of_float !type_of_aux'_add_time) ;
+ prerr_endline
+ ("++++++++++++ Tempi della type_of_aux'_add_time nella double_type_inference(" ^ string_of_int !DoubleTypeInference.number_new_type_of_aux'_double_work ^ ";" ^ string_of_int !DoubleTypeInference.number_new_type_of_aux'_prop ^ "/" ^ string_of_int !DoubleTypeInference.number_new_type_of_aux' ^ "): " ^ string_of_float !DoubleTypeInference.type_of_aux'_add_time) ;
+ prerr_endline
+ ("++++++++++++ Tempi della syntactic_equality_add_time: " ^ string_of_float !DoubleTypeInference.syntactic_equality_add_time) ;
+ prerr_endline
+ ("++++++++++ Tempi della acic_of_cic: " ^ string_of_float (time3 -. time2)) ;
+ prerr_endline
+ ("++++++++++ Numero di iterazioni della acic_of_cic: " ^ string_of_int !seed) ;
+*)
+ C.ACurrentProof
+ ("mettereaposto","mettereaposto2",id,aconjectures,abo,aty,params,attrs)
+ | C.InductiveDefinition (tys,params,paramsno,attrs) ->
+ let tys =
+ List.map
+ (fun (name,i,arity,cl) ->
+ (name,i,Unshare.unshare arity,
+ List.map (fun (name,ty) -> name,Unshare.unshare ty) cl)) tys in
+ let context =
+ List.map
+ (fun (name,_,arity,_) ->
+ Some (C.Name name, C.Decl (Unshare.unshare arity))) tys in
+ let idrefs = List.map (function _ -> gen_id seed) tys in
+ let atys =
+ List.map2
+ (fun id (name,inductive,ty,cons) ->
+ let acons =
+ List.map
+ (function (name,ty) ->
+ (name,
+ acic_term_of_cic_term_context' ~computeinnertypes:false [] context idrefs ty None)
+ ) cons
+ in
+ (id,name,inductive,
+ acic_term_of_cic_term' ~computeinnertypes:false ty None,acons)
+ ) (List.rev idrefs) tys
+ in
+ C.AInductiveDefinition ("mettereaposto",atys,params,paramsno,attrs)
+ in
+ aobj,ids_to_terms,ids_to_father_ids,ids_to_inner_sorts,ids_to_inner_types,
+ ids_to_conjectures,ids_to_hypotheses
+;;
+
+let plain_acic_term_of_cic_term =
+ let module C = Cic in
+ let mk_fresh_id =
+ let id = ref 0 in
+ function () -> incr id; "i" ^ string_of_int !id in
+ let rec aux context t =
+ let fresh_id = mk_fresh_id () in
+ match t with
+ C.Rel n ->
+ let idref,id =
+ match get_nth context n with
+ idref,(Some (C.Name s,_)) -> idref,s
+ | idref,_ -> idref,"__" ^ string_of_int n
+ in
+ C.ARel (fresh_id, idref, n, id)
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map
+ (function i,t -> i, (aux context t)) exp_named_subst
+ in
+ C.AVar (fresh_id,uri,exp_named_subst')
+ | C.Implicit _
+ | C.Meta _ -> assert false
+ | C.Sort s -> C.ASort (fresh_id, s)
+ | C.Cast (v,t) ->
+ C.ACast (fresh_id, aux context v, aux context t)
+ | C.Prod (n,s,t) ->
+ C.AProd
+ (fresh_id, n, aux context s,
+ aux ((fresh_id, Some (n, C.Decl s))::context) t)
+ | C.Lambda (n,s,t) ->
+ C.ALambda
+ (fresh_id,n, aux context s,
+ aux ((fresh_id, Some (n, C.Decl s))::context) t)
+ | C.LetIn (n,s,t) ->
+ C.ALetIn
+ (fresh_id, n, aux context s,
+ aux ((fresh_id, Some (n, C.Def(s,None)))::context) t)
+ | C.Appl l ->
+ C.AAppl (fresh_id, List.map (aux context) l)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map
+ (function i,t -> i, (aux context t)) exp_named_subst
+ in
+ C.AConst (fresh_id, uri, exp_named_subst')
+ | C.MutInd (uri,tyno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map
+ (function i,t -> i, (aux context t)) exp_named_subst
+ in
+ C.AMutInd (fresh_id, uri, tyno, exp_named_subst')
+ | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map
+ (function i,t -> i, (aux context t)) exp_named_subst
+ in
+ C.AMutConstruct (fresh_id, uri, tyno, consno, exp_named_subst')
+ | C.MutCase (uri, tyno, outty, term, patterns) ->
+ C.AMutCase (fresh_id, uri, tyno, aux context outty,
+ aux context term, List.map (aux context) patterns)
+ | C.Fix (funno, funs) ->
+ let tys =
+ List.map
+ (fun (name,_,ty,_) -> mk_fresh_id (), Some (C.Name name, C.Decl ty)) funs
+ in
+ C.AFix (fresh_id, funno,
+ List.map2
+ (fun (id,_) (name, indidx, ty, bo) ->
+ (id, name, indidx, aux context ty, aux (tys@context) bo)
+ ) tys funs
+ )
+ | C.CoFix (funno, funs) ->
+ let tys =
+ List.map (fun (name,ty,_) ->
+ mk_fresh_id (),Some (C.Name name, C.Decl ty)) funs
+ in
+ C.ACoFix (fresh_id, funno,
+ List.map2
+ (fun (id,_) (name, ty, bo) ->
+ (id, name, aux context ty, aux (tys@context) bo)
+ ) tys funs
+ )
+ in
+ aux
+;;
+
+let plain_acic_object_of_cic_object obj =
+ let module C = Cic in
+ let mk_fresh_id =
+ let id = ref 0 in
+ function () -> incr id; "it" ^ string_of_int !id
+ in
+ match obj with
+ C.Constant (id,Some bo,ty,params,attrs) ->
+ let abo = plain_acic_term_of_cic_term [] bo in
+ let aty = plain_acic_term_of_cic_term [] ty in
+ C.AConstant
+ ("mettereaposto",Some "mettereaposto2",id,Some abo,aty,params,attrs)
+ | C.Constant (id,None,ty,params,attrs) ->
+ let aty = plain_acic_term_of_cic_term [] ty in
+ C.AConstant
+ ("mettereaposto",None,id,None,aty,params,attrs)
+ | C.Variable (id,bo,ty,params,attrs) ->
+ let abo =
+ match bo with
+ None -> None
+ | Some bo -> Some (plain_acic_term_of_cic_term [] bo)
+ in
+ let aty = plain_acic_term_of_cic_term [] ty in
+ C.AVariable
+ ("mettereaposto",id,abo,aty,params,attrs)
+ | C.CurrentProof _ -> assert false
+ | C.InductiveDefinition (tys,params,paramsno,attrs) ->
+ let context =
+ List.map
+ (fun (name,_,arity,_) ->
+ mk_fresh_id (), Some (C.Name name, C.Decl arity)) tys in
+ let atys =
+ List.map2
+ (fun (id,_) (name,inductive,ty,cons) ->
+ let acons =
+ List.map
+ (function (name,ty) ->
+ (name,
+ plain_acic_term_of_cic_term context ty)
+ ) cons
+ in
+ (id,name,inductive,plain_acic_term_of_cic_term [] ty,acons)
+ ) context tys
+ in
+ C.AInductiveDefinition ("mettereaposto",atys,params,paramsno,attrs)
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception NotEnoughElements
+
+val source_id_of_id : string -> string
+
+type anntypes =
+ {annsynthesized : Cic.annterm ; annexpected : Cic.annterm option}
+;;
+
+type sort_kind = [ `Prop | `Set | `Type of CicUniv.universe | `CProp ]
+
+val string_of_sort: sort_kind -> string
+(*val sort_of_string: string -> sort_kind*)
+val sort_of_sort: Cic.sort -> sort_kind
+
+val acic_object_of_cic_object :
+ ?eta_fix: bool -> (* perform eta_fixing; default: true*)
+ Cic.obj -> (* object *)
+ Cic.annobj * (* annotated object *)
+ (Cic.id, Cic.term) Hashtbl.t * (* ids_to_terms *)
+ (Cic.id, Cic.id option) Hashtbl.t * (* ids_to_father_ids *)
+ (Cic.id, sort_kind) Hashtbl.t * (* ids_to_inner_sorts *)
+ (Cic.id, anntypes) Hashtbl.t * (* ids_to_inner_types *)
+ (Cic.id, Cic.conjecture) Hashtbl.t * (* ids_to_conjectures *)
+ (Cic.id, Cic.hypothesis) Hashtbl.t (* ids_to_hypotheses *)
+
+val asequent_of_sequent :
+ Cic.metasenv -> (* metasenv *)
+ Cic.conjecture -> (* sequent *)
+ Cic.conjecture * (* unshared sequent *)
+ (Cic.annconjecture * (* annotated sequent *)
+ (Cic.id, Cic.term) Hashtbl.t * (* ids_to_terms *)
+ (Cic.id, Cic.id option) Hashtbl.t * (* ids_to_father_ids *)
+ (Cic.id, sort_kind) Hashtbl.t * (* ids_to_inner_sorts *)
+ (Cic.id, Cic.hypothesis) Hashtbl.t) (* ids_to_hypotheses *)
+
+val plain_acic_object_of_cic_object : Cic.obj -> Cic.annobj
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception Impossible of int;;
+exception NotWellTyped of string;;
+exception WrongUriToConstant of string;;
+exception WrongUriToVariable of string;;
+exception WrongUriToMutualInductiveDefinitions of string;;
+exception ListTooShort;;
+exception RelToHiddenHypothesis;;
+
+let syntactic_equality_add_time = ref 0.0;;
+let type_of_aux'_add_time = ref 0.0;;
+let number_new_type_of_aux'_double_work = ref 0;;
+let number_new_type_of_aux' = ref 0;;
+let number_new_type_of_aux'_prop = ref 0;;
+
+let double_work = ref 0;;
+
+let xxx_type_of_aux' m c t =
+ let t1 = Sys.time () in
+ let res,_ = CicTypeChecker.type_of_aux' m c t CicUniv.empty_ugraph in
+ let t2 = Sys.time () in
+ type_of_aux'_add_time := !type_of_aux'_add_time +. t2 -. t1 ;
+ res
+;;
+
+type types = {synthesized : Cic.term ; expected : Cic.term option};;
+
+(* does_not_occur n te *)
+(* returns [true] if [Rel n] does not occur in [te] *)
+let rec does_not_occur n =
+ let module C = Cic in
+ function
+ C.Rel m when m = n -> false
+ | C.Rel _
+ | C.Meta _
+ | C.Sort _
+ | C.Implicit _ -> true
+ | C.Cast (te,ty) ->
+ does_not_occur n te && does_not_occur n ty
+ | C.Prod (name,so,dest) ->
+ does_not_occur n so &&
+ does_not_occur (n + 1) dest
+ | C.Lambda (name,so,dest) ->
+ does_not_occur n so &&
+ does_not_occur (n + 1) dest
+ | C.LetIn (name,so,dest) ->
+ does_not_occur n so &&
+ does_not_occur (n + 1) dest
+ | C.Appl l ->
+ List.fold_right (fun x i -> i && does_not_occur n x) l true
+ | C.Var (_,exp_named_subst)
+ | C.Const (_,exp_named_subst)
+ | C.MutInd (_,_,exp_named_subst)
+ | C.MutConstruct (_,_,_,exp_named_subst) ->
+ List.fold_right (fun (_,x) i -> i && does_not_occur n x)
+ exp_named_subst true
+ | C.MutCase (_,_,out,te,pl) ->
+ does_not_occur n out && does_not_occur n te &&
+ List.fold_right (fun x i -> i && does_not_occur n x) pl true
+ | C.Fix (_,fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len in
+ let tys =
+ List.map (fun (n,_,ty,_) -> Some (C.Name n,(Cic.Decl ty))) fl
+ in
+ List.fold_right
+ (fun (_,_,ty,bo) i ->
+ i && does_not_occur n ty &&
+ does_not_occur n_plus_len bo
+ ) fl true
+ | C.CoFix (_,fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len in
+ let tys =
+ List.map (fun (n,ty,_) -> Some (C.Name n,(Cic.Decl ty))) fl
+ in
+ List.fold_right
+ (fun (_,ty,bo) i ->
+ i && does_not_occur n ty &&
+ does_not_occur n_plus_len bo
+ ) fl true
+;;
+
+let rec beta_reduce =
+ let module S = CicSubstitution in
+ let module C = Cic in
+ function
+ C.Rel _ as t -> t
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (i,t) -> i, beta_reduce t) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst)
+ | C.Meta (n,l) ->
+ C.Meta (n,
+ List.map
+ (function None -> None | Some t -> Some (beta_reduce t)) l
+ )
+ | C.Sort _ as t -> t
+ | C.Implicit _ -> assert false
+ | C.Cast (te,ty) ->
+ C.Cast (beta_reduce te, beta_reduce ty)
+ | C.Prod (n,s,t) ->
+ C.Prod (n, beta_reduce s, beta_reduce t)
+ | C.Lambda (n,s,t) ->
+ C.Lambda (n, beta_reduce s, beta_reduce t)
+ | C.LetIn (n,s,t) ->
+ C.LetIn (n, beta_reduce s, beta_reduce t)
+ | C.Appl ((C.Lambda (name,s,t))::he::tl) ->
+ let he' = S.subst he t in
+ if tl = [] then
+ beta_reduce he'
+ else
+ (match he' with
+ C.Appl l -> beta_reduce (C.Appl (l@tl))
+ | _ -> beta_reduce (C.Appl (he'::tl)))
+ | C.Appl l ->
+ C.Appl (List.map beta_reduce l)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (i,t) -> i, beta_reduce t) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,i,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (i,t) -> i, beta_reduce t) exp_named_subst
+ in
+ C.MutInd (uri,i,exp_named_subst')
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (i,t) -> i, beta_reduce t) exp_named_subst
+ in
+ C.MutConstruct (uri,i,j,exp_named_subst')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,beta_reduce outt,beta_reduce t,
+ List.map beta_reduce pl)
+ | C.Fix (i,fl) ->
+ let fl' =
+ List.map
+ (function (name,i,ty,bo) ->
+ name,i,beta_reduce ty,beta_reduce bo
+ ) fl
+ in
+ C.Fix (i,fl')
+ | C.CoFix (i,fl) ->
+ let fl' =
+ List.map
+ (function (name,ty,bo) ->
+ name,beta_reduce ty,beta_reduce bo
+ ) fl
+ in
+ C.CoFix (i,fl')
+;;
+
+(* syntactic_equality up to the *)
+(* distinction between fake dependent products *)
+(* and non-dependent products, alfa-conversion *)
+(*CSC: must alfa-conversion be considered or not? *)
+let syntactic_equality t t' =
+ let module C = Cic in
+ let rec syntactic_equality t t' =
+ if t = t' then true
+ else
+ match t, t' with
+ C.Var (uri,exp_named_subst), C.Var (uri',exp_named_subst') ->
+ UriManager.eq uri uri' &&
+ syntactic_equality_exp_named_subst exp_named_subst exp_named_subst'
+ | C.Cast (te,ty), C.Cast (te',ty') ->
+ syntactic_equality te te' &&
+ syntactic_equality ty ty'
+ | C.Prod (_,s,t), C.Prod (_,s',t') ->
+ syntactic_equality s s' &&
+ syntactic_equality t t'
+ | C.Lambda (_,s,t), C.Lambda (_,s',t') ->
+ syntactic_equality s s' &&
+ syntactic_equality t t'
+ | C.LetIn (_,s,t), C.LetIn(_,s',t') ->
+ syntactic_equality s s' &&
+ syntactic_equality t t'
+ | C.Appl l, C.Appl l' ->
+ List.fold_left2 (fun b t1 t2 -> b && syntactic_equality t1 t2) true l l'
+ | C.Const (uri,exp_named_subst), C.Const (uri',exp_named_subst') ->
+ UriManager.eq uri uri' &&
+ syntactic_equality_exp_named_subst exp_named_subst exp_named_subst'
+ | C.MutInd (uri,i,exp_named_subst), C.MutInd (uri',i',exp_named_subst') ->
+ UriManager.eq uri uri' && i = i' &&
+ syntactic_equality_exp_named_subst exp_named_subst exp_named_subst'
+ | C.MutConstruct (uri,i,j,exp_named_subst),
+ C.MutConstruct (uri',i',j',exp_named_subst') ->
+ UriManager.eq uri uri' && i = i' && j = j' &&
+ syntactic_equality_exp_named_subst exp_named_subst exp_named_subst'
+ | C.MutCase (sp,i,outt,t,pl), C.MutCase (sp',i',outt',t',pl') ->
+ UriManager.eq sp sp' && i = i' &&
+ syntactic_equality outt outt' &&
+ syntactic_equality t t' &&
+ List.fold_left2
+ (fun b t1 t2 -> b && syntactic_equality t1 t2) true pl pl'
+ | C.Fix (i,fl), C.Fix (i',fl') ->
+ i = i' &&
+ List.fold_left2
+ (fun b (_,i,ty,bo) (_,i',ty',bo') ->
+ b && i = i' &&
+ syntactic_equality ty ty' &&
+ syntactic_equality bo bo') true fl fl'
+ | C.CoFix (i,fl), C.CoFix (i',fl') ->
+ i = i' &&
+ List.fold_left2
+ (fun b (_,ty,bo) (_,ty',bo') ->
+ b &&
+ syntactic_equality ty ty' &&
+ syntactic_equality bo bo') true fl fl'
+ | _, _ -> false (* we already know that t != t' *)
+ and syntactic_equality_exp_named_subst exp_named_subst1 exp_named_subst2 =
+ List.fold_left2
+ (fun b (_,t1) (_,t2) -> b && syntactic_equality t1 t2) true
+ exp_named_subst1 exp_named_subst2
+ in
+ try
+ syntactic_equality t t'
+ with
+ _ -> false
+;;
+
+let xxx_syntactic_equality t t' =
+ let t1 = Sys.time () in
+ let res = syntactic_equality t t' in
+ let t2 = Sys.time () in
+ syntactic_equality_add_time := !syntactic_equality_add_time +. t2 -. t1 ;
+ res
+;;
+
+
+let rec split l n =
+ match (l,n) with
+ (l,0) -> ([], l)
+ | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2)
+ | (_,_) -> raise ListTooShort
+;;
+
+let type_of_constant uri =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let cobj =
+ match CicEnvironment.is_type_checked CicUniv.empty_ugraph uri with
+ CicEnvironment.CheckedObj (cobj,_) -> cobj
+ | CicEnvironment.UncheckedObj uobj ->
+ raise (NotWellTyped "Reference to an unchecked constant")
+ in
+ match cobj with
+ C.Constant (_,_,ty,_,_) -> ty
+ | C.CurrentProof (_,_,_,ty,_,_) -> ty
+ | _ -> raise (WrongUriToConstant (U.string_of_uri uri))
+;;
+
+let type_of_variable uri =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ match CicEnvironment.is_type_checked CicUniv.empty_ugraph uri with
+ CicEnvironment.CheckedObj ((C.Variable (_,_,ty,_,_)),_) -> ty
+ | CicEnvironment.UncheckedObj (C.Variable _) ->
+ raise (NotWellTyped "Reference to an unchecked variable")
+ | _ -> raise (WrongUriToVariable (UriManager.string_of_uri uri))
+;;
+
+let type_of_mutual_inductive_defs uri i =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let cobj =
+ match CicEnvironment.is_type_checked CicUniv.empty_ugraph uri with
+ CicEnvironment.CheckedObj (cobj,_) -> cobj
+ | CicEnvironment.UncheckedObj uobj ->
+ raise (NotWellTyped "Reference to an unchecked inductive type")
+ in
+ match cobj with
+ C.InductiveDefinition (dl,_,_,_) ->
+ let (_,_,arity,_) = List.nth dl i in
+ arity
+ | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+;;
+
+let type_of_mutual_inductive_constr uri i j =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let cobj =
+ match CicEnvironment.is_type_checked CicUniv.empty_ugraph uri with
+ CicEnvironment.CheckedObj (cobj,_) -> cobj
+ | CicEnvironment.UncheckedObj uobj ->
+ raise (NotWellTyped "Reference to an unchecked constructor")
+ in
+ match cobj with
+ C.InductiveDefinition (dl,_,_,_) ->
+ let (_,_,_,cl) = List.nth dl i in
+ let (_,ty) = List.nth cl (j-1) in
+ ty
+ | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+;;
+
+module CicHash =
+ struct
+ module Tmp =
+ Hashtbl.Make
+ (struct
+ type t = Cic.term
+ let equal = (==)
+ let hash = Hashtbl.hash
+ end)
+ include Tmp
+ let empty () = Tmp.create 1
+ end
+;;
+
+(* type_of_aux' is just another name (with a different scope) for type_of_aux *)
+let rec type_of_aux' subterms_to_types metasenv context t expectedty =
+ (* Coscoy's double type-inference algorithm *)
+ (* It computes the inner-types of every subterm of [t], *)
+ (* even when they are not needed to compute the types *)
+ (* of other terms. *)
+ let rec type_of_aux context t expectedty =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module S = CicSubstitution in
+ let module U = UriManager in
+ let synthesized =
+ match t with
+ C.Rel n ->
+ (try
+ match List.nth context (n - 1) with
+ Some (_,C.Decl t) -> S.lift n t
+ | Some (_,C.Def (_,Some ty)) -> S.lift n ty
+ | Some (_,C.Def (bo,None)) ->
+ type_of_aux context (S.lift n bo) expectedty
+ | None -> raise RelToHiddenHypothesis
+ with
+ _ -> raise (NotWellTyped "Not a close term")
+ )
+ | C.Var (uri,exp_named_subst) ->
+ visit_exp_named_subst context uri exp_named_subst ;
+ CicSubstitution.subst_vars exp_named_subst (type_of_variable uri)
+ | C.Meta (n,l) ->
+ (* Let's visit all the subterms that will not be visited later *)
+ let (_,canonical_context,_) = CicUtil.lookup_meta n metasenv in
+ let lifted_canonical_context =
+ let rec aux i =
+ function
+ [] -> []
+ | (Some (n,C.Decl t))::tl ->
+ (Some (n,C.Decl (S.subst_meta l (S.lift i t))))::(aux (i+1) tl)
+ | (Some (n,C.Def (t,None)))::tl ->
+ (Some (n,C.Def ((S.subst_meta l (S.lift i t)),None)))::
+ (aux (i+1) tl)
+ | None::tl -> None::(aux (i+1) tl)
+ | (Some (_,C.Def (_,Some _)))::_ -> assert false
+ in
+ aux 1 canonical_context
+ in
+ let _ =
+ List.iter2
+ (fun t ct ->
+ match t,ct with
+ _,None -> ()
+ | Some t,Some (_,C.Def (ct,_)) ->
+ let expected_type =
+ R.whd context
+ (xxx_type_of_aux' metasenv context ct)
+ in
+ (* Maybe I am a bit too paranoid, because *)
+ (* if the term is well-typed than t and ct *)
+ (* are convertible. Nevertheless, I compute *)
+ (* the expected type. *)
+ ignore (type_of_aux context t (Some expected_type))
+ | Some t,Some (_,C.Decl ct) ->
+ ignore (type_of_aux context t (Some ct))
+ | _,_ -> assert false (* the term is not well typed!!! *)
+ ) l lifted_canonical_context
+ in
+ let (_,canonical_context,ty) = CicUtil.lookup_meta n metasenv in
+ (* Checks suppressed *)
+ CicSubstitution.subst_meta l ty
+ | C.Sort (C.Type t) -> (* TASSI: CONSTRAINT *)
+ C.Sort (C.Type (CicUniv.fresh()))
+ | C.Sort _ -> C.Sort (C.Type (CicUniv.fresh())) (* TASSI: CONSTRAINT *)
+ | C.Implicit _ -> raise (Impossible 21)
+ | C.Cast (te,ty) ->
+ (* Let's visit all the subterms that will not be visited later *)
+ let _ = type_of_aux context te (Some (beta_reduce ty)) in
+ let _ = type_of_aux context ty None in
+ (* Checks suppressed *)
+ ty
+ | C.Prod (name,s,t) ->
+ let sort1 = type_of_aux context s None
+ and sort2 = type_of_aux ((Some (name,(C.Decl s)))::context) t None in
+ sort_of_prod context (name,s) (sort1,sort2)
+ | C.Lambda (n,s,t) ->
+ (* Let's visit all the subterms that will not be visited later *)
+ let _ = type_of_aux context s None in
+ let expected_target_type =
+ match expectedty with
+ None -> None
+ | Some expectedty' ->
+ let ty =
+ match R.whd context expectedty' with
+ C.Prod (_,_,expected_target_type) ->
+ beta_reduce expected_target_type
+ | _ -> assert false
+ in
+ Some ty
+ in
+ let type2 =
+ type_of_aux ((Some (n,(C.Decl s)))::context) t expected_target_type
+ in
+ (* Checks suppressed *)
+ C.Prod (n,s,type2)
+ | C.LetIn (n,s,t) ->
+(*CSC: What are the right expected types for the source and *)
+(*CSC: target of a LetIn? None used. *)
+ (* Let's visit all the subterms that will not be visited later *)
+ let ty = type_of_aux context s None in
+ let t_typ =
+ (* Checks suppressed *)
+ type_of_aux ((Some (n,(C.Def (s,Some ty))))::context) t None
+ in (* CicSubstitution.subst s t_typ *)
+ if does_not_occur 1 t_typ then
+ (* since [Rel 1] does not occur in typ, substituting any term *)
+ (* in place of [Rel 1] is equivalent to delifting once *)
+ CicSubstitution.subst (C.Implicit None) t_typ
+ else
+ C.LetIn (n,s,t_typ)
+ | C.Appl (he::tl) when List.length tl > 0 ->
+ (*
+ let expected_hetype =
+ (* Inefficient, the head is computed twice. But I know *)
+ (* of no other solution. *)
+ (beta_reduce
+ (R.whd context (xxx_type_of_aux' metasenv context he)))
+ in
+ let hetype = type_of_aux context he (Some expected_hetype) in
+ let tlbody_and_type =
+ let rec aux =
+ function
+ _,[] -> []
+ | C.Prod (n,s,t),he::tl ->
+ (he, type_of_aux context he (Some (beta_reduce s)))::
+ (aux (R.whd context (S.subst he t), tl))
+ | _ -> assert false
+ in
+ aux (expected_hetype, tl) *)
+ let hetype = R.whd context (type_of_aux context he None) in
+ let tlbody_and_type =
+ let rec aux =
+ function
+ _,[] -> []
+ | C.Prod (n,s,t),he::tl ->
+ (he, type_of_aux context he (Some (beta_reduce s)))::
+ (aux (R.whd context (S.subst he t), tl))
+ | _ -> assert false
+ in
+ aux (hetype, tl)
+ in
+ eat_prods context hetype tlbody_and_type
+ | C.Appl _ -> raise (NotWellTyped "Appl: no arguments")
+ | C.Const (uri,exp_named_subst) ->
+ visit_exp_named_subst context uri exp_named_subst ;
+ CicSubstitution.subst_vars exp_named_subst (type_of_constant uri)
+ | C.MutInd (uri,i,exp_named_subst) ->
+ visit_exp_named_subst context uri exp_named_subst ;
+ CicSubstitution.subst_vars exp_named_subst
+ (type_of_mutual_inductive_defs uri i)
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ visit_exp_named_subst context uri exp_named_subst ;
+ CicSubstitution.subst_vars exp_named_subst
+ (type_of_mutual_inductive_constr uri i j)
+ | C.MutCase (uri,i,outtype,term,pl) ->
+ let outsort = type_of_aux context outtype None in
+ let (need_dummy, k) =
+ let rec guess_args context t =
+ match CicReduction.whd context t with
+ C.Sort _ -> (true, 0)
+ | C.Prod (name, s, t) ->
+ let (b, n) = guess_args ((Some (name,(C.Decl s)))::context) t in
+ if n = 0 then
+ (* last prod before sort *)
+ match CicReduction.whd context s with
+ C.MutInd (uri',i',_) when U.eq uri' uri && i' = i ->
+ (false, 1)
+ | C.Appl ((C.MutInd (uri',i',_)) :: _)
+ when U.eq uri' uri && i' = i -> (false, 1)
+ | _ -> (true, 1)
+ else
+ (b, n + 1)
+ | _ -> raise (NotWellTyped "MutCase: outtype ill-formed")
+ in
+ let (b, k) = guess_args context outsort in
+ if not b then (b, k - 1) else (b, k)
+ in
+ let (parameters, arguments,exp_named_subst) =
+ let type_of_term =
+ xxx_type_of_aux' metasenv context term
+ in
+ match
+ R.whd context (type_of_aux context term
+ (Some (beta_reduce type_of_term)))
+ with
+ (*CSC manca il caso dei CAST *)
+ C.MutInd (uri',i',exp_named_subst) ->
+ (* Checks suppressed *)
+ [],[],exp_named_subst
+ | C.Appl (C.MutInd (uri',i',exp_named_subst) :: tl) ->
+ let params,args =
+ split tl (List.length tl - k)
+ in params,args,exp_named_subst
+ | _ ->
+ raise (NotWellTyped "MutCase: the term is not an inductive one")
+ in
+ (* Checks suppressed *)
+ (* Let's visit all the subterms that will not be visited later *)
+ let (cl,parsno) =
+ let obj,_ =
+ try
+ CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
+ with Not_found -> assert false
+ in
+ match obj with
+ C.InductiveDefinition (tl,_,parsno,_) ->
+ let (_,_,_,cl) = List.nth tl i in (cl,parsno)
+ | _ ->
+ raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+ in
+ let _ =
+ List.fold_left
+ (fun j (p,(_,c)) ->
+ let cons =
+ if parameters = [] then
+ (C.MutConstruct (uri,i,j,exp_named_subst))
+ else
+ (C.Appl (C.MutConstruct (uri,i,j,exp_named_subst)::parameters))
+ in
+ let expectedtype =
+ type_of_branch context parsno need_dummy outtype cons
+ (xxx_type_of_aux' metasenv context cons)
+ in
+ ignore (type_of_aux context p
+ (Some (beta_reduce expectedtype))) ;
+ j+1
+ ) 1 (List.combine pl cl)
+ in
+ if not need_dummy then
+ C.Appl ((outtype::arguments)@[term])
+ else if arguments = [] then
+ outtype
+ else
+ C.Appl (outtype::arguments)
+ | C.Fix (i,fl) ->
+ (* Let's visit all the subterms that will not be visited later *)
+ let context' =
+ List.rev
+ (List.map
+ (fun (n,_,ty,_) ->
+ let _ = type_of_aux context ty None in
+ (Some (C.Name n,(C.Decl ty)))
+ ) fl
+ ) @
+ context
+ in
+ let _ =
+ List.iter
+ (fun (_,_,ty,bo) ->
+ let expectedty =
+ beta_reduce (CicSubstitution.lift (List.length fl) ty)
+ in
+ ignore (type_of_aux context' bo (Some expectedty))
+ ) fl
+ in
+ (* Checks suppressed *)
+ let (_,_,ty,_) = List.nth fl i in
+ ty
+ | C.CoFix (i,fl) ->
+ (* Let's visit all the subterms that will not be visited later *)
+ let context' =
+ List.rev
+ (List.map
+ (fun (n,ty,_) ->
+ let _ = type_of_aux context ty None in
+ (Some (C.Name n,(C.Decl ty)))
+ ) fl
+ ) @
+ context
+ in
+ let _ =
+ List.iter
+ (fun (_,ty,bo) ->
+ let expectedty =
+ beta_reduce (CicSubstitution.lift (List.length fl) ty)
+ in
+ ignore (type_of_aux context' bo (Some expectedty))
+ ) fl
+ in
+ (* Checks suppressed *)
+ let (_,ty,_) = List.nth fl i in
+ ty
+ in
+ let synthesized' = beta_reduce synthesized in
+ let types,res =
+ match expectedty with
+ None ->
+ (* No expected type *)
+ {synthesized = synthesized' ; expected = None}, synthesized
+ | Some ty when xxx_syntactic_equality synthesized' ty ->
+ (* The expected type is synthactically equal to *)
+ (* the synthesized type. Let's forget it. *)
+ {synthesized = synthesized' ; expected = None}, synthesized
+ | Some expectedty' ->
+ {synthesized = synthesized' ; expected = Some expectedty'},
+ expectedty'
+ in
+ assert (not (CicHash.mem subterms_to_types t));
+ CicHash.add subterms_to_types t types ;
+ res
+
+ and visit_exp_named_subst context uri exp_named_subst =
+ let uris_and_types =
+ let obj,_ =
+ try
+ CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
+ with Not_found -> assert false
+ in
+ let params = CicUtil.params_of_obj obj in
+ List.map
+ (function uri ->
+ let obj,_ =
+ try
+ CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
+ with Not_found -> assert false
+ in
+ match obj with
+ Cic.Variable (_,None,ty,_,_) -> uri,ty
+ | _ -> assert false (* the theorem is well-typed *)
+ ) params
+ in
+ let rec check uris_and_types subst =
+ match uris_and_types,subst with
+ _,[] -> []
+ | (uri,ty)::tytl,(uri',t)::substtl when uri = uri' ->
+ ignore (type_of_aux context t (Some ty)) ;
+ let tytl' =
+ List.map
+ (function uri,t' -> uri,(CicSubstitution.subst_vars [uri',t] t')) tytl
+ in
+ check tytl' substtl
+ | _,_ -> assert false (* the theorem is well-typed *)
+ in
+ check uris_and_types exp_named_subst
+
+ and sort_of_prod context (name,s) (t1, t2) =
+ let module C = Cic in
+ let t1' = CicReduction.whd context t1 in
+ let t2' = CicReduction.whd ((Some (name,C.Decl s))::context) t2 in
+ match (t1', t2') with
+ (C.Sort _, C.Sort s2)
+ when (s2 = C.Prop or s2 = C.Set or s2 = C.CProp) ->
+ (* different from Coq manual!!! *)
+ C.Sort s2
+ | (C.Sort (C.Type t1), C.Sort (C.Type t2)) ->
+ C.Sort (C.Type (CicUniv.fresh()))
+ | (C.Sort _,C.Sort (C.Type t1)) ->
+ (* TASSI: CONSRTAINTS: the same in cictypechecker,cicrefine *)
+ C.Sort (C.Type t1) (* c'e' bisogno di un fresh? *)
+ | (C.Meta _, C.Sort _) -> t2'
+ | (C.Meta _, (C.Meta (_,_) as t))
+ | (C.Sort _, (C.Meta (_,_) as t)) when CicUtil.is_closed t ->
+ t2'
+ | (_,_) ->
+ raise
+ (NotWellTyped
+ ("Prod: sort1= " ^ CicPp.ppterm t1' ^ " ; sort2= " ^ CicPp.ppterm t2'))
+
+ and eat_prods context hetype =
+ (*CSC: siamo sicuri che le are_convertible non lavorino con termini non *)
+ (*CSC: cucinati *)
+ function
+ [] -> hetype
+ | (hete, hety)::tl ->
+ (match (CicReduction.whd context hetype) with
+ Cic.Prod (n,s,t) ->
+ (* Checks suppressed *)
+ eat_prods context (CicSubstitution.subst hete t) tl
+ | _ -> raise (NotWellTyped "Appl: wrong Prod-type")
+ )
+
+and type_of_branch context argsno need_dummy outtype term constype =
+ let module C = Cic in
+ let module R = CicReduction in
+ match R.whd context constype with
+ C.MutInd (_,_,_) ->
+ if need_dummy then
+ outtype
+ else
+ C.Appl [outtype ; term]
+ | C.Appl (C.MutInd (_,_,_)::tl) ->
+ let (_,arguments) = split tl argsno
+ in
+ if need_dummy && arguments = [] then
+ outtype
+ else
+ C.Appl (outtype::arguments@(if need_dummy then [] else [term]))
+ | C.Prod (name,so,de) ->
+ let term' =
+ match CicSubstitution.lift 1 term with
+ C.Appl l -> C.Appl (l@[C.Rel 1])
+ | t -> C.Appl [t ; C.Rel 1]
+ in
+ C.Prod (C.Anonymous,so,type_of_branch
+ ((Some (name,(C.Decl so)))::context) argsno need_dummy
+ (CicSubstitution.lift 1 outtype) term' de)
+ | _ -> raise (Impossible 20)
+
+ in
+ type_of_aux context t expectedty
+;;
+
+let double_type_of metasenv context t expectedty =
+ let subterms_to_types = CicHash.create 503 in
+ ignore (type_of_aux' subterms_to_types metasenv context t expectedty) ;
+ subterms_to_types
+;;
--- /dev/null
+exception Impossible of int
+exception NotWellTyped of string
+exception WrongUriToConstant of string
+exception WrongUriToVariable of string
+exception WrongUriToMutualInductiveDefinitions of string
+exception ListTooShort
+exception RelToHiddenHypothesis
+
+val syntactic_equality_add_time: float ref
+val type_of_aux'_add_time: float ref
+val number_new_type_of_aux'_double_work: int ref
+val number_new_type_of_aux': int ref
+val number_new_type_of_aux'_prop: int ref
+
+type types = {synthesized : Cic.term ; expected : Cic.term option};;
+
+module CicHash :
+ sig
+ type 'a t
+ val find : 'a t -> Cic.term -> 'a
+ val empty: unit -> 'a t
+ end
+;;
+
+val double_type_of :
+ Cic.metasenv -> Cic.context -> Cic.term -> Cic.term option -> types CicHash.t
+
+(** Auxiliary functions **)
+
+(* does_not_occur n te *)
+(* returns [true] if [Rel n] does not occur in [te] *)
+val does_not_occur : int -> Cic.term -> bool
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception ReferenceToNonVariable;;
+
+let prerr_endline _ = ();;
+
+(*
+let rec fix_lambdas_wrt_type ty te =
+ let module C = Cic in
+ let module S = CicSubstitution in
+(* prerr_endline ("entering fix_lambdas: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *)
+ match ty with
+ C.Prod (_,_,ty') ->
+ (match CicReduction.whd [] te with
+ C.Lambda (n,s,te') ->
+ C.Lambda (n,s,fix_lambdas_wrt_type ty' te')
+ | t ->
+ let rec get_sources =
+ function
+ C.Prod (_,s,ty) -> s::(get_sources ty)
+ | _ -> [] in
+ let sources = get_sources ty in
+ let no_sources = List.length sources in
+ let rec mk_rels n shift =
+ if n = 0 then []
+ else (C.Rel (n + shift))::(mk_rels (n - 1) shift) in
+ let t' = S.lift no_sources t in
+ let t2 =
+ match t' with
+ C.Appl l ->
+ C.LetIn
+ (C.Name "w",t',C.Appl ((C.Rel 1)::(mk_rels no_sources 1)))
+ | _ ->
+ C.Appl (t'::(mk_rels no_sources 0)) in
+ List.fold_right
+ (fun source t -> C.Lambda (C.Name "y",source,t))
+ sources t2)
+ | _ -> te
+;; *)
+
+let rec fix_lambdas_wrt_type ty te =
+ let module C = Cic in
+ let module S = CicSubstitution in
+(* prerr_endline ("entering fix_lambdas: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *)
+ match ty,te with
+ C.Prod (_,_,ty'), C.Lambda (n,s,te') ->
+ C.Lambda (n,s,fix_lambdas_wrt_type ty' te')
+ | C.Prod (_,s,ty'), t ->
+ let rec get_sources =
+ function
+ C.Prod (_,s,ty) -> s::(get_sources ty)
+ | _ -> [] in
+ let sources = get_sources ty in
+ let no_sources = List.length sources in
+ let rec mk_rels n shift =
+ if n = 0 then []
+ else (C.Rel (n + shift))::(mk_rels (n - 1) shift) in
+ let t' = S.lift no_sources t in
+ let t2 =
+ match t' with
+ C.Appl l ->
+ C.LetIn (C.Name "w",t',C.Appl ((C.Rel 1)::(mk_rels no_sources 1)))
+ | _ -> C.Appl (t'::(mk_rels no_sources 0)) in
+ List.fold_right
+ (fun source t -> C.Lambda (C.Name "y",CicReduction.whd [] source,t)) sources t2
+ | _, _ -> te
+;;
+
+(*
+let rec fix_lambdas_wrt_type ty te =
+ let module C = Cic in
+ let module S = CicSubstitution in
+(* prerr_endline ("entering fix_lambdas: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *)
+ match ty,te with
+ C.Prod (_,_,ty'), C.Lambda (n,s,te') ->
+ C.Lambda (n,s,fix_lambdas_wrt_type ty' te')
+ | C.Prod (_,s,ty'), ((C.Appl (C.Const _ ::_)) as t) ->
+ (* const have a fixed arity *)
+ (* prerr_endline ("******** fl - eta expansion 0: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *)
+ let t' = S.lift 1 t in
+ C.Lambda (C.Name "x",s,
+ C.LetIn
+ (C.Name "H", fix_lambdas_wrt_type ty' t',
+ C.Appl [C.Rel 1;C.Rel 2]))
+ | C.Prod (_,s,ty'), C.Appl l ->
+ (* prerr_endline ("******** fl - eta expansion 1: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *)
+ let l' = List.map (S.lift 1) l in
+ C.Lambda (C.Name "x",s,
+ fix_lambdas_wrt_type ty' (C.Appl (l'@[C.Rel 1])))
+ | C.Prod (_,s,ty'), _ ->
+ (* prerr_endline ("******** fl - eta expansion 2: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *)
+ flush stderr ;
+ let te' = S.lift 1 te in
+ C.Lambda (C.Name "x",s,
+ fix_lambdas_wrt_type ty' (C.Appl [te';C.Rel 1]))
+ | _, _ -> te
+;;*)
+
+let fix_according_to_type ty hd tl =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let rec count_prods =
+ function
+ C.Prod (_,_,t) -> 1 + (count_prods t)
+ | _ -> 0 in
+ let expected_arity = count_prods ty in
+ let rec aux n ty tl res =
+ if n = 0 then
+ (match tl with
+ [] ->
+ (match res with
+ [] -> assert false
+ | [res] -> res
+ | _ -> C.Appl res)
+ | _ ->
+ match res with
+ [] -> assert false
+ | [a] -> C.Appl (a::tl)
+ | _ ->
+ (* prerr_endline ("******* too many args: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm (C.Appl res)); *)
+ C.LetIn
+ (C.Name "H",
+ C.Appl res, C.Appl (C.Rel 1::(List.map (S.lift 1) tl))))
+ else
+ let name,source,target =
+ (match ty with
+ C.Prod (C.Name _ as n,s,t) -> n,s,t
+ | C.Prod (C.Anonymous, s,t) -> C.Name "z",s,t
+ | _ -> (* prods number may only increase for substitution *)
+ assert false) in
+ match tl with
+ [] ->
+ (* prerr_endline ("******* too few args: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm (C.Appl res)); *)
+ let res' = List.map (S.lift 1) res in
+ C.Lambda
+ (name, source, aux (n-1) target [] (res'@[C.Rel 1]))
+ | hd::tl' ->
+ let hd' = fix_lambdas_wrt_type source hd in
+ (* (prerr_endline ("++++++prima :" ^(CicPp.ppterm hd));
+ prerr_endline ("++++++dopo :" ^(CicPp.ppterm hd'))); *)
+ aux (n-1) (S.subst hd' target) tl' (res@[hd']) in
+ aux expected_arity ty tl [hd]
+;;
+
+let eta_fix metasenv context t =
+ let rec eta_fix' context t =
+ (* prerr_endline ("entering aux with: term=" ^ CicPp.ppterm t);
+ flush stderr ; *)
+ let module C = Cic in
+ let module S = CicSubstitution in
+ match t with
+ C.Rel n -> C.Rel n
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' = fix_exp_named_subst context exp_named_subst in
+ C.Var (uri,exp_named_subst')
+ | C.Meta (n,l) ->
+ let (_,canonical_context,_) = CicUtil.lookup_meta n metasenv in
+ let l' =
+ List.map2
+ (fun ct t ->
+ match (ct, t) with
+ None, _ -> None
+ | _, Some t -> Some (eta_fix' context t)
+ | Some _, None -> assert false (* due to typing rules *))
+ canonical_context l
+ in
+ C.Meta (n,l')
+ | C.Sort s -> C.Sort s
+ | C.Implicit _ as t -> t
+ | C.Cast (v,t) -> C.Cast (eta_fix' context v, eta_fix' context t)
+ | C.Prod (n,s,t) ->
+ C.Prod
+ (n, eta_fix' context s, eta_fix' ((Some (n,(C.Decl s)))::context) t)
+ | C.Lambda (n,s,t) ->
+ C.Lambda
+ (n, eta_fix' context s, eta_fix' ((Some (n,(C.Decl s)))::context) t)
+ | C.LetIn (n,s,t) ->
+ C.LetIn
+ (n,eta_fix' context s,eta_fix' ((Some (n,(C.Def (s,None))))::context) t)
+ | C.Appl l as appl ->
+ let l' = List.map (eta_fix' context) l
+ in
+ (match l' with
+ [] -> assert false
+ | he::tl ->
+ let ty,_ =
+ CicTypeChecker.type_of_aux' metasenv context he
+ CicUniv.empty_ugraph
+ in
+ fix_according_to_type ty he tl
+(*
+ C.Const(uri,exp_named_subst)::l'' ->
+ let constant_type =
+ (match CicEnvironment.get_obj uri with
+ C.Constant (_,_,ty,_) -> ty
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof (_,_,_,_,params) -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ ) in
+ fix_according_to_type
+ constant_type (C.Const(uri,exp_named_subst)) l''
+ | _ -> C.Appl l' *))
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' = fix_exp_named_subst context exp_named_subst in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,tyno,exp_named_subst) ->
+ let exp_named_subst' = fix_exp_named_subst context exp_named_subst in
+ C.MutInd (uri, tyno, exp_named_subst')
+ | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
+ let exp_named_subst' = fix_exp_named_subst context exp_named_subst in
+ C.MutConstruct (uri, tyno, consno, exp_named_subst')
+ | C.MutCase (uri, tyno, outty, term, patterns) as prima ->
+ let outty' = eta_fix' context outty in
+ let term' = eta_fix' context term in
+ let patterns' = List.map (eta_fix' context) patterns in
+ let inductive_types,noparams =
+ let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ (match o with
+ Cic.Constant _ -> assert false
+ | Cic.Variable _ -> assert false
+ | Cic.CurrentProof _ -> assert false
+ | Cic.InductiveDefinition (l,_,n,_) -> l,n
+ ) in
+ let (_,_,_,constructors) = List.nth inductive_types tyno in
+ let constructor_types =
+ let rec clean_up t =
+ function
+ [] -> t
+ | a::tl ->
+ (match t with
+ Cic.Prod (_,_,t') -> clean_up (S.subst a t') tl
+ | _ -> assert false) in
+ if noparams = 0 then
+ List.map (fun (_,t) -> t) constructors
+ else
+ let term_type,_ =
+ CicTypeChecker.type_of_aux' metasenv context term
+ CicUniv.empty_ugraph
+ in
+ (match term_type with
+ C.Appl (hd::params) ->
+ let rec first_n n l =
+ if n = 0 then []
+ else
+ (match l with
+ a::tl -> a::(first_n (n-1) tl)
+ | _ -> assert false) in
+ List.map
+ (fun (_,t) ->
+ clean_up t (first_n noparams params)) constructors
+ | _ -> prerr_endline ("QUA"); assert false) in
+ let patterns2 =
+ List.map2 fix_lambdas_wrt_type
+ constructor_types patterns in
+ C.MutCase (uri, tyno, outty',term',patterns2)
+ | C.Fix (funno, funs) ->
+ let fun_types =
+ List.map (fun (n,_,ty,_) -> Some (C.Name n,(Cic.Decl ty))) funs in
+ C.Fix (funno,
+ List.map
+ (fun (name, no, ty, bo) ->
+ (name, no, eta_fix' context ty, eta_fix' (fun_types@context) bo))
+ funs)
+ | C.CoFix (funno, funs) ->
+ let fun_types =
+ List.map (fun (n,ty,_) -> Some (C.Name n,(Cic.Decl ty))) funs in
+ C.CoFix (funno,
+ List.map
+ (fun (name, ty, bo) ->
+ (name, eta_fix' context ty, eta_fix' (fun_types@context) bo)) funs)
+ and fix_exp_named_subst context exp_named_subst =
+ List.rev
+ (List.fold_left
+ (fun newsubst (uri,t) ->
+ let t' = eta_fix' context t in
+ let ty =
+ let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ match o with
+ Cic.Variable (_,_,ty,_,_) ->
+ CicSubstitution.subst_vars newsubst ty
+ | _ -> raise ReferenceToNonVariable
+ in
+ let t'' = fix_according_to_type ty t' [] in
+ (uri,t'')::newsubst
+ ) [] exp_named_subst)
+ in
+ eta_fix' context t
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val eta_fix : Cic.metasenv -> Cic.context -> Cic.term -> Cic.term
+
+
disambiguateChoices.cmi: disambiguateTypes.cmi
-disambiguatePp.cmi: disambiguateTypes.cmi
disambiguate.cmi: disambiguateTypes.cmi
disambiguateTypes.cmo: disambiguateTypes.cmi
disambiguateTypes.cmx: disambiguateTypes.cmi
disambiguateChoices.cmo: disambiguateTypes.cmi disambiguateChoices.cmi
disambiguateChoices.cmx: disambiguateTypes.cmx disambiguateChoices.cmi
-disambiguatePp.cmo: disambiguateTypes.cmi disambiguateChoices.cmi \
- disambiguatePp.cmi
-disambiguatePp.cmx: disambiguateTypes.cmx disambiguateChoices.cmx \
- disambiguatePp.cmi
disambiguate.cmo: disambiguateTypes.cmi disambiguateChoices.cmi \
disambiguate.cmi
disambiguate.cmx: disambiguateTypes.cmx disambiguateChoices.cmx \
INTERFACE_FILES = \
disambiguateTypes.mli \
disambiguateChoices.mli \
- disambiguatePp.mli \
disambiguate.mli
IMPLEMENTATION_FILES = \
$(patsubst %.mli, %.ml, $(INTERFACE_FILES)) \
assert (context = []);
assert (is_path = false);
match obj with
- | GrafiteAst.Inductive (params,tyl) ->
+ | CicNotationPt.Inductive (params,tyl) ->
let uri = match uri with Some uri -> uri | None -> assert false in
let context,params =
let context,res =
) tyl
in
Cic.InductiveDefinition (tyl,[],List.length params,[])
- | GrafiteAst.Record (params,name,ty,fields) ->
+ | CicNotationPt.Record (params,name,ty,fields) ->
let uri = match uri with Some uri -> uri | None -> assert false in
let context,params =
let context,res =
let field_names = List.map fst fields in
Cic.InductiveDefinition
(tyl,[],List.length params,[`Class (`Record field_names)])
- | GrafiteAst.Theorem (flavour, name, ty, bo) ->
+ | CicNotationPt.Theorem (flavour, name, ty, bo) ->
let attrs = [`Flavour flavour] in
let ty' = interpretate_term [] env None false ty in
(match bo with
assert (context = []);
let domain_rev =
match ast with
- | GrafiteAst.Theorem (_,_,ty,bo) ->
+ | CicNotationPt.Theorem (_,_,ty,bo) ->
(match bo with
None -> []
| Some bo -> domain_rev_of_term [] bo) @
domain_of_term [] ty
- | GrafiteAst.Inductive (params,tyl) ->
+ | CicNotationPt.Inductive (params,tyl) ->
let dom =
List.flatten (
List.rev_map
not ( List.exists (fun (name',_) -> name = Id name') params
|| List.exists (fun (name',_,_,_) -> name = Id name') tyl)
) dom
- | GrafiteAst.Record (params,_,ty,fields) ->
+ | CicNotationPt.Record (params,_,ty,fields) ->
let dom =
List.flatten
(List.rev_map (fun (_,ty) -> domain_rev_of_term [] ty) fields) in
aliases:DisambiguateTypes.environment ->(* previous interpretation status *)
universe:DisambiguateTypes.multiple_environment option ->
uri:UriManager.uri option -> (* required only for inductive types *)
- GrafiteAst.obj ->
+ CicNotationPt.obj ->
((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list *
Cic.metasenv * (* new metasenv *)
Cic.obj *
| Id id -> choices_of_id dbd id
| Symbol (symb, _) ->
List.map DisambiguateChoices.mk_choice
- (CicNotationRew.lookup_interpretations symb)
+ (TermAcicContent.lookup_interpretations symb)
| Num instance ->
DisambiguateChoices.lookup_num_choices ()
in
if fresh_instances then CicNotationUtil.freshen_obj obj else obj
in
disambiguate_thing ~dbd ~context:[] ~metasenv:[] ~aliases ~universe ~uri
- ~pp_thing:GrafiteAstPp.pp_obj ~domain_of_thing:domain_of_obj
+ ~pp_thing:CicNotationPp.pp_obj ~domain_of_thing:domain_of_obj
~interpretate_thing:interpretate_obj ~refine_thing:refine_obj
obj
end
exception PathNotWellFormed
val interpretate_path :
- context:Cic.name list -> DisambiguateTypes.term ->
+ context:Cic.name list -> CicNotationPt.term ->
Cic.term
module type Disambiguator =
?initial_ugraph:CicUniv.universe_graph ->
aliases:DisambiguateTypes.environment ->(* previous interpretation status *)
universe:DisambiguateTypes.multiple_environment option ->
- DisambiguateTypes.term ->
+ CicNotationPt.term ->
((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list *
Cic.metasenv * (* new metasenv *)
Cic.term *
aliases:DisambiguateTypes.environment ->(* previous interpretation status *)
universe:DisambiguateTypes.multiple_environment option ->
uri:UriManager.uri option -> (* required only for inductive types *)
- GrafiteAst.obj ->
+ CicNotationPt.obj ->
((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list *
Cic.metasenv * (* new metasenv *)
Cic.obj *
with Invalid_argument _ ->
raise (Invalid_choice (lazy "The notation expects a different number of arguments"))
in
- CicNotationFwd.instantiate_appl_pattern env' appl_pattern)
+ TermAcicContent.instantiate_appl_pattern env' appl_pattern)
let lookup_symbol_by_dsc symbol dsc =
try
mk_choice
(List.find
(fun (dsc', _, _) -> dsc = dsc')
- (CicNotationRew.lookup_interpretations symbol))
- with CicNotationRew.Interpretation_not_found | Not_found ->
+ (TermAcicContent.lookup_interpretations symbol))
+ with TermAcicContent.Interpretation_not_found | Not_found ->
raise (Choice_not_found (lazy (sprintf "Symbol %s, dsc %s" symbol dsc)))
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open DisambiguateTypes
-
-let parse_environment str =
- let stream = Ulexing.from_utf8_string str in
- let environment = ref Environment.empty in
- let multiple_environment = ref Environment.empty in
- try
- while true do
- let alias =
- match GrafiteParser.parse_statement stream with
- GrafiteAst.Executable (_, GrafiteAst.Command (_, GrafiteAst.Alias (_,alias)))
- -> alias
- | _ -> assert false in
- let key,value =
- (*CSC: Warning: this code should be factorized with the corresponding
- code in MatitaEngine *)
- match alias with
- GrafiteAst.Ident_alias (id,uri) ->
- Id id,
- (uri,(fun _ _ _-> CicUtil.term_of_uri (UriManager.uri_of_string uri)))
- | GrafiteAst.Symbol_alias (symb,instance,desc) ->
- Symbol (symb,instance),
- DisambiguateChoices.lookup_symbol_by_dsc symb desc
- | GrafiteAst.Number_alias (instance,desc) ->
- Num instance,
- DisambiguateChoices.lookup_num_by_dsc desc
- in
- environment := Environment.add key value !environment;
- multiple_environment := Environment.cons key value !multiple_environment;
- done;
- assert false
- with End_of_file ->
- !environment, !multiple_environment
-
-let alias_of_domain_and_codomain_items domain_item (dsc,_) =
- match domain_item with
- Id id -> GrafiteAst.Ident_alias (id, dsc)
- | Symbol (symb, i) -> GrafiteAst.Symbol_alias (symb, i, dsc)
- | Num i -> GrafiteAst.Number_alias (i, dsc)
-
-let aliases_of_environment env =
- Environment.fold
- (fun domain_item codomain_item acc ->
- alias_of_domain_and_codomain_items domain_item codomain_item::acc
- ) env []
-
-let aliases_of_domain_and_codomain_items_list l =
- List.fold_left
- (fun acc (domain_item,codomain_item) ->
- alias_of_domain_and_codomain_items domain_item codomain_item::acc
- ) [] l
-
-let pp_environment env =
- let aliases = aliases_of_environment env in
- let strings =
- List.map (fun alias -> GrafiteAstPp.pp_alias alias ^ ".") aliases
- in
- String.concat "\n" (List.sort compare strings)
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-val parse_environment:
- string ->
- DisambiguateTypes.environment * DisambiguateTypes.multiple_environment
-
-val aliases_of_domain_and_codomain_items_list:
- (DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list ->
- GrafiteAst.alias_spec list
-
-val pp_environment: DisambiguateTypes.environment -> string
* http://helm.cs.unibo.it/
*)
+(*
type term = CicNotationPt.term
type tactic = (term, term, GrafiteAst.reduction, string) GrafiteAst.tactic
type tactical = (term, term, GrafiteAst.reduction, string) GrafiteAst.tactical
| Command of tactical
| Comment of CicNotationPt.location * string
type script = CicNotationPt.location * script_entry list
+*)
type domain_item =
| Id of string (* literal *)
(** {3 type shortands} *)
+(*
type term = CicNotationPt.term
type tactic = (term, term, GrafiteAst.reduction, string) GrafiteAst.tactic
type tactical = (term, term, GrafiteAst.reduction, string) GrafiteAst.tactical
| Command of tactical
| Comment of CicNotationPt.location * string
type script = CicNotationPt.location * script_entry list
+*)
val dummy_floc: Lexing.position * Lexing.position
+++ /dev/null
-*.cm[aiox]
-*.cmxa
-*.[ao]
-test_lexer
-test_parser
-test_dep
-print_grammar
+++ /dev/null
-cicNotationUtil.cmi: grafiteAst.cmo cicNotationPt.cmo
-cicNotationTag.cmi: cicNotationPt.cmo
-cicNotationEnv.cmi: cicNotationPt.cmo
-cicNotationPp.cmi: cicNotationPt.cmo cicNotationEnv.cmi
-grafiteAstPp.cmi: grafiteAst.cmo cicNotationPt.cmo
-cicNotationMatcher.cmi: cicNotationPt.cmo cicNotationEnv.cmi
-cicNotationFwd.cmi: cicNotationPt.cmo cicNotationEnv.cmi
-cicNotationRew.cmi: cicNotationPt.cmo
-cicNotationParser.cmi: cicNotationPt.cmo cicNotationEnv.cmi
-grafiteParser.cmi: grafiteAst.cmo cicNotationPt.cmo
-cicNotationPres.cmi: mpresentation.cmi cicNotationPt.cmo box.cmi
-boxPp.cmi: cicNotationPres.cmi
-cicNotation.cmi: grafiteAst.cmo
-grafiteAst.cmo: cicNotationPt.cmo
-grafiteAst.cmx: cicNotationPt.cmx
-renderingAttrs.cmo: renderingAttrs.cmi
-renderingAttrs.cmx: renderingAttrs.cmi
-cicNotationUtil.cmo: grafiteAst.cmo cicNotationPt.cmo cicNotationUtil.cmi
-cicNotationUtil.cmx: grafiteAst.cmx cicNotationPt.cmx cicNotationUtil.cmi
-cicNotationTag.cmo: cicNotationUtil.cmi cicNotationPt.cmo cicNotationTag.cmi
-cicNotationTag.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationTag.cmi
-cicNotationLexer.cmo: cicNotationLexer.cmi
-cicNotationLexer.cmx: cicNotationLexer.cmi
-cicNotationEnv.cmo: cicNotationUtil.cmi cicNotationPt.cmo cicNotationEnv.cmi
-cicNotationEnv.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationEnv.cmi
-cicNotationPp.cmo: cicNotationPt.cmo cicNotationEnv.cmi cicNotationPp.cmi
-cicNotationPp.cmx: cicNotationPt.cmx cicNotationEnv.cmx cicNotationPp.cmi
-grafiteAstPp.cmo: grafiteAst.cmo cicNotationPt.cmo cicNotationPp.cmi \
- grafiteAstPp.cmi
-grafiteAstPp.cmx: grafiteAst.cmx cicNotationPt.cmx cicNotationPp.cmx \
- grafiteAstPp.cmi
-cicNotationMatcher.cmo: grafiteAstPp.cmi cicNotationUtil.cmi \
- cicNotationTag.cmi cicNotationPt.cmo cicNotationPp.cmi cicNotationEnv.cmi \
- cicNotationMatcher.cmi
-cicNotationMatcher.cmx: grafiteAstPp.cmx cicNotationUtil.cmx \
- cicNotationTag.cmx cicNotationPt.cmx cicNotationPp.cmx cicNotationEnv.cmx \
- cicNotationMatcher.cmi
-cicNotationFwd.cmo: cicNotationUtil.cmi cicNotationPt.cmo cicNotationPp.cmi \
- cicNotationEnv.cmi cicNotationFwd.cmi
-cicNotationFwd.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationPp.cmx \
- cicNotationEnv.cmx cicNotationFwd.cmi
-cicNotationRew.cmo: renderingAttrs.cmi cicNotationUtil.cmi cicNotationPt.cmo \
- cicNotationPp.cmi cicNotationMatcher.cmi cicNotationEnv.cmi \
- cicNotationRew.cmi
-cicNotationRew.cmx: renderingAttrs.cmx cicNotationUtil.cmx cicNotationPt.cmx \
- cicNotationPp.cmx cicNotationMatcher.cmx cicNotationEnv.cmx \
- cicNotationRew.cmi
-cicNotationParser.cmo: cicNotationUtil.cmi cicNotationPt.cmo \
- cicNotationPp.cmi cicNotationLexer.cmi cicNotationEnv.cmi \
- cicNotationParser.cmi
-cicNotationParser.cmx: cicNotationUtil.cmx cicNotationPt.cmx \
- cicNotationPp.cmx cicNotationLexer.cmx cicNotationEnv.cmx \
- cicNotationParser.cmi
-grafiteParser.cmo: grafiteAst.cmo cicNotationPt.cmo cicNotationParser.cmi \
- cicNotationLexer.cmi grafiteParser.cmi
-grafiteParser.cmx: grafiteAst.cmx cicNotationPt.cmx cicNotationParser.cmx \
- cicNotationLexer.cmx grafiteParser.cmi
-mpresentation.cmo: mpresentation.cmi
-mpresentation.cmx: mpresentation.cmi
-box.cmo: renderingAttrs.cmi box.cmi
-box.cmx: renderingAttrs.cmx box.cmi
-cicNotationPres.cmo: renderingAttrs.cmi mpresentation.cmi cicNotationUtil.cmi \
- cicNotationPt.cmo cicNotationPp.cmi box.cmi cicNotationPres.cmi
-cicNotationPres.cmx: renderingAttrs.cmx mpresentation.cmx cicNotationUtil.cmx \
- cicNotationPt.cmx cicNotationPp.cmx box.cmx cicNotationPres.cmi
-boxPp.cmo: renderingAttrs.cmi mpresentation.cmi cicNotationPres.cmi box.cmi \
- boxPp.cmi
-boxPp.cmx: renderingAttrs.cmx mpresentation.cmx cicNotationPres.cmx box.cmx \
- boxPp.cmi
-cicNotation.cmo: grafiteParser.cmi grafiteAst.cmo cicNotationRew.cmi \
- cicNotationParser.cmi cicNotationFwd.cmi cicNotation.cmi
-cicNotation.cmx: grafiteParser.cmx grafiteAst.cmx cicNotationRew.cmx \
- cicNotationParser.cmx cicNotationFwd.cmx cicNotation.cmi
+++ /dev/null
-
-PACKAGE = cic_notation
-NULL =
-INTERFACE_FILES = \
- renderingAttrs.mli \
- cicNotationUtil.mli \
- cicNotationTag.mli \
- cicNotationLexer.mli \
- cicNotationEnv.mli \
- cicNotationPp.mli \
- grafiteAstPp.mli \
- cicNotationMatcher.mli \
- cicNotationFwd.mli \
- cicNotationRew.mli \
- cicNotationParser.mli \
- grafiteParser.mli \
- mpresentation.mli \
- box.mli \
- cicNotationPres.mli \
- boxPp.mli \
- cicNotation.mli \
- $(NULL)
-IMPLEMENTATION_FILES = \
- cicNotationPt.ml \
- grafiteAst.ml \
- $(patsubst %.mli, %.ml, $(INTERFACE_FILES)) \
- $(NULL)
-
-all: test_lexer test_parser test_dep print_grammar
-
-LOCAL_LINKOPTS = -package helm-cic_notation -linkpkg
-test: test_lexer test_parser test_dep
-test_lexer: test_lexer.ml $(PACKAGE).cma
- $(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
-test_parser: REQUIRES += helm-cic_omdoc
-test_parser: test_parser.ml $(PACKAGE).cma
- $(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
-test_dep: test_dep.ml $(PACKAGE).cma
- $(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
-print_grammar: print_grammar.ml $(PACKAGE).cma
- $(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
-
-cicNotationLexer.cmo: OCAMLC = $(OCAMLC_P4)
-cicNotationParser.cmo: OCAMLC = $(OCAMLC_P4)
-grafiteParser.cmo: OCAMLC = $(OCAMLC_P4)
-cicNotationLexer.cmx: OCAMLOPT = $(OCAMLOPT_P4)
-cicNotationParser.cmx: OCAMLOPT = $(OCAMLOPT_P4)
-grafiteParser.cmx: OCAMLOPT = $(OCAMLOPT_P4)
-cicNotationParser.ml.annot: OCAMLC = $(OCAMLC_P4)
-grafiteParser.ml.annot: OCAMLC = $(OCAMLC_P4)
-cicNotationLexer.ml.annot: OCAMLC = $(OCAMLC_P4)
-cicNotationPres.cmi: OCAMLOPTIONS += -rectypes
-cicNotationPres.cmo: OCAMLOPTIONS += -rectypes
-cicNotationPres.cmx: OCAMLOPTIONS += -rectypes
-
-clean: extra_clean
-distclean: extra_clean
- rm -f macro_table.dump
-extra_clean:
- rm -f test_lexer test_parser
-
-include ../Makefile.common
-OCAMLARCHIVEOPTIONS += -linkall
-
-cicNotationParser.expanded.ml: cicNotationParser.ml
- camlp4 -nolib '-I' '/usr/lib/ocaml/3.08.3/' '-I' '/home/zack/helm/ocaml/urimanager' '-I' '/usr/lib/ocaml/3.08.3/pcre' '-I' '/usr/lib/ocaml/3.08.3/' '-I' '/usr/lib/ocaml/3.08.3/netstring' '-I' '/usr/lib/ocaml/3.08.3/pxp-engine' '-I' '/usr/lib/ocaml/3.08.3/pxp-lex-utf8' '-I' '/usr/lib/ocaml/3.08.3/pxp-lex-iso88591' '-I' '/usr/lib/ocaml/3.08.3/pxp-lex-iso885915' '-I' '/usr/lib/ocaml/3.08.3/http' '-I' '/home/zacchiro/helm/ocaml/pxp' '-I' '/usr/lib/ocaml/3.08.3/zip' '-I' '/usr/lib/ocaml/3.08.3/expat' '-I' '/home/zacchiro/helm/ocaml/xml' '-I' '/home/zack/helm/ocaml/cic' '-I' '/usr/lib/ocaml/3.08.3/camlp4' '-I' '/home/zack/helm/ocaml/utf8_macros' '-I' '/usr/lib/ocaml/3.08.3/camlp4' '-I' '/usr/lib/ocaml/3.08.3/ulex' 'pa_o.cmo' 'pa_op.cmo' 'pr_o.cmo' 'pa_extend.cmo' 'pa_unicode_macro.cma' 'pa_ulex.cma' $< > $@
-
+++ /dev/null
-
-TODO
-
-* implementare type-checker per le trasformazioni
-* prestazioni trasformazioni 3 => 2 e 2 => 1
-* magic per gestione degli array?
-* gestione della notazione per i numeri
-* sintassi concreta
- - studiare/implementare sintassi con ... per i magic fold
-* trasformazioni
- - parentesi cagose (tail)
- - hyperlink multipli con il magic fold (e.g. notazione per le liste)
- - ident0 -> ident_0 ?
-
-DONE
-
-* trasformazioni
- - spacing delle keyword
- - hyperlink su head dei case pattern e sul tipo induttivo su cui si fa match
-* bug di rimozione della notazione: pare che camlp4 distrugga un livello
- grammaticale quando toglie l'ultima produzione ivi definita
-* pretty printing verso testo
-* gestione priorita'/associativita'
- - triplicare livelli nella grammatica?
-* implementare trasformazione 1 => 0
-* implementare istanziazione dei magic a livello 1 (2 => 1)
-* implementare compilazione dei default in 2 => 1
-* annotazioni nel livello 1 generato
-* problema con pattern overlapping per i magic al livello 2
-* gestione greedyness dei magic in 2 => 1
-* href multipli
-* integrazione
- - apportare all'ast le modifiche di CicAst (case, cast non come annotazione,
- tipi opzionali nel let rec e nelle definizioni)
-* integrazione
- - porting della disambiguazione al nuovo ast
- - refactoring: unico punto di accesso allo stato imperativo della notazione
- - gestire cast
- - salvare la notazione nei file .moo
- - portare le trasformazioni al nuovo ast
- - gestire i problemi di ridefinizione della stessa notazione?
- - togliere file non piu' utilizzati (caterva di cvs remove)
-* gtkmathview
- - aggiungere metodo per caricare un file di configurazione dell'utente (idem
- nel binding)
- - algoritmo di layout delle scatole
-
+++ /dev/null
-(* Copyright (C) 2000-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(*************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 13/2/2004 *)
-(* *)
-(*************************************************************************)
-
-type
- 'expr box =
- Text of attr * string
- | Space of attr
- | Ink of attr
- | H of attr * ('expr box) list
- | V of attr * ('expr box) list
- | HV of attr * ('expr box) list
- | HOV of attr * ('expr box) list
- | Object of attr * 'expr
- | Action of attr * ('expr box) list
-
-and attr = (string option * string * string) list
-
-let smallskip = Space([None,"width","0.5em"]);;
-let skip = Space([None,"width","1em"]);;
-
-let indent t = H([],[skip;t]);;
-
-(* BoxML prefix *)
-let prefix = "b";;
-
-let tag_of_box = function
- | H _ -> "h"
- | V _ -> "v"
- | HV _ -> "hv"
- | HOV _ -> "hov"
- | _ -> assert false
-
-let box2xml ~obj2xml box =
- let rec aux =
- let module X = Xml in
- function
- Text (attr,s) -> X.xml_nempty ~prefix "text" attr (X.xml_cdata s)
- | Space attr -> X.xml_empty ~prefix "space" attr
- | Ink attr -> X.xml_empty ~prefix "ink" attr
- | H (attr,l)
- | V (attr,l)
- | HV (attr,l)
- | HOV (attr,l) as box ->
- X.xml_nempty ~prefix (tag_of_box box) attr
- [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>])
- >]
- | Object (attr,m) ->
- X.xml_nempty ~prefix "obj" attr [< obj2xml m >]
- | Action (attr,l) ->
- X.xml_nempty ~prefix "action" attr
- [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) >]
- in
- aux box
-;;
-
-let rec map f = function
- | (Text _) as box -> box
- | (Space _) as box -> box
- | (Ink _) as box -> box
- | H (attr, l) -> H (attr, List.map (map f) l)
- | V (attr, l) -> V (attr, List.map (map f) l)
- | HV (attr, l) -> HV (attr, List.map (map f) l)
- | HOV (attr, l) -> HOV (attr, List.map (map f) l)
- | Action (attr, l) -> Action (attr, List.map (map f) l)
- | Object (attr, obj) -> Object (attr, f obj)
-;;
-
-(*
-let document_of_box ~obj2xml pres =
- [< Xml.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- Xml.xml_cdata "\n";
- Xml.xml_nempty ~prefix "box"
- [Some "xmlns","m","http://www.w3.org/1998/Math/MathML" ;
- Some "xmlns","b","http://helm.cs.unibo.it/2003/BoxML" ;
- Some "xmlns","helm","http://www.cs.unibo.it/helm" ;
- Some "xmlns","xlink","http://www.w3.org/1999/xlink"
- ] (print_box pres)
- >]
-*)
-
-let b_h a b = H(a,b)
-let b_v a b = V(a,b)
-let b_hv a b = HV(a,b)
-let b_hov a b = HOV(a,b)
-let b_text a b = Text(a,b)
-let b_object b = Object ([],b)
-let b_indent = indent
-let b_space = Space [None, "width", "0.5em"]
-let b_kw = b_text (RenderingAttrs.object_keyword_attributes `BoxML)
-
-let pp_attr attr =
- let pp (ns, n, v) =
- Printf.sprintf "%s%s=%s" (match ns with None -> "" | Some s -> s ^ ":") n v
- in
- String.concat " " (List.map pp attr)
-
-let get_attr = function
- | Text (attr, _)
- | Space attr
- | Ink attr
- | H (attr, _)
- | V (attr, _)
- | HV (attr, _)
- | HOV (attr, _)
- | Object (attr, _)
- | Action (attr, _) ->
- attr
-
-let set_attr attr = function
- | Text (_, x) -> Text (attr, x)
- | Space _ -> Space attr
- | Ink _ -> Ink attr
- | H (_, x) -> H (attr, x)
- | V (_, x) -> V (attr, x)
- | HV (_, x) -> HV (attr, x)
- | HOV (_, x) -> HOV (attr, x)
- | Object (_, x) -> Object (attr, x)
- | Action (_, x) -> Action (attr, x)
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(*************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 13/2/2004 *)
-(* *)
-(*************************************************************************)
-
-type
- 'expr box =
- Text of attr * string
- | Space of attr
- | Ink of attr
- | H of attr * ('expr box) list
- | V of attr * ('expr box) list
- | HV of attr * ('expr box) list
- | HOV of attr * ('expr box) list
- | Object of attr * 'expr
- | Action of attr * ('expr box) list
-
-and attr = (string option * string * string) list
-
-val get_attr: 'a box -> attr
-val set_attr: attr -> 'a box -> 'a box
-
-val smallskip : 'expr box
-val skip: 'expr box
-val indent : 'expr box -> 'expr box
-
-val box2xml:
- obj2xml:('a -> Xml.token Stream.t) -> 'a box ->
- Xml.token Stream.t
-
-val map: ('a -> 'b) -> 'a box -> 'b box
-
-(*
-val document_of_box :
- ~obj2xml:('a -> Xml.token Stream.t) -> 'a box -> Xml.token Stream.t
-*)
-
-val b_h: attr -> 'expr box list -> 'expr box
-val b_v: attr -> 'expr box list -> 'expr box
-val b_hv: attr -> 'expr box list -> 'expr box (** default indent and spacing *)
-val b_hov: attr -> 'expr box list -> 'expr box (** default indent and spacing *)
-val b_text: attr -> string -> 'expr box
-val b_object: 'expr -> 'expr box
-val b_indent: 'expr box -> 'expr box
-val b_space: 'expr box
-val b_kw: string -> 'expr box
-
-val pp_attr: attr -> string
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-module Pres = Mpresentation
-
-(** {2 Pretty printing from BoxML to strings} *)
-
-let string_space = " "
-let string_space_len = String.length string_space
-let string_indent = string_space
-let string_indent_len = String.length string_indent
-let string_ink = "##"
-let string_ink_len = String.length string_ink
-
-let contains_attrs contained container =
- List.for_all (fun attr -> List.mem attr container) contained
-
-let want_indent = contains_attrs (RenderingAttrs.indent_attributes `BoxML)
-let want_spacing = contains_attrs (RenderingAttrs.spacing_attributes `BoxML)
-
-let indent_string s = string_indent ^ s
-let indent_children (size, children) =
- let children' = List.map indent_string children in
- size + string_space_len, children'
-
-let choose_rendering size (best, other) =
- let best_size, _ = best in
- if size >= best_size then best else other
-
-let merge_columns sep cols =
- let sep_len = String.length sep in
- let indent = ref 0 in
- let res_rows = ref [] in
- let add_row ~continue row =
- match !res_rows with
- | last :: prev when continue ->
- res_rows := (String.concat sep [last; row]) :: prev;
- indent := !indent + String.length last + sep_len
- | _ -> res_rows := (String.make !indent ' ' ^ row) :: !res_rows;
- in
- List.iter
- (fun rows ->
- match rows with
- | hd :: tl ->
- add_row ~continue:true hd;
- List.iter (add_row ~continue:false) tl
- | [] -> ())
- cols;
- List.rev !res_rows
-
-let max_len =
- List.fold_left (fun max_size s -> max (String.length s) max_size) 0
-
-let render_row available_space spacing children =
- let spacing_bonus = if spacing then string_space_len else 0 in
- let rem_space = ref available_space in
- let renderings = ref [] in
- List.iter
- (fun f ->
- let occupied_space, rendering = f !rem_space in
- renderings := rendering :: !renderings;
- rem_space := !rem_space - (occupied_space + spacing_bonus))
- children;
- let sep = if spacing then string_space else "" in
- let rendering = merge_columns sep (List.rev !renderings) in
- max_len rendering, rendering
-
-let fixed_rendering s =
- let s_len = String.length s in
- (fun _ -> s_len, [s])
-
-let render_to_strings size markup =
- let max_size = max_int in
- let rec aux_box =
- function
- | Box.Text (_, t) -> fixed_rendering t
- | Box.Space _ -> fixed_rendering string_space
- | Box.Ink _ -> fixed_rendering string_ink
- | Box.Action (_, []) -> assert false
- | Box.Action (_, hd :: _) -> aux_box hd
- | Box.Object (_, o) -> aux_mpres o
- | Box.H (attrs, children) ->
- let spacing = want_spacing attrs in
- let children' = List.map aux_box children in
- (fun size -> render_row size spacing children')
- | Box.HV (attrs, children) ->
- let spacing = want_spacing attrs in
- let children' = List.map aux_box children in
- (fun size ->
- let (size', renderings) as res =
- render_row max_size spacing children'
- in
- if size' <= size then (* children fit in a row *)
- res
- else (* break needed, re-render using a Box.V *)
- aux_box (Box.V (attrs, children)) size)
- | Box.V (attrs, []) -> assert false
- | Box.V (attrs, [child]) -> aux_box child
- | Box.V (attrs, hd :: tl) ->
- let indent = want_indent attrs in
- let hd_f = aux_box hd in
- let tl_fs = List.map aux_box tl in
- (fun size ->
- let _, hd_rendering = hd_f size in
- let children_size =
- max 0 (if indent then size - string_indent_len else size)
- in
- let tl_renderings =
- List.map
- (fun f ->
- let indent_header = if indent then string_indent else "" in
- snd (indent_children (f children_size)))
- tl_fs
- in
- let rows = hd_rendering @ List.concat tl_renderings in
- max_len rows, rows)
- | Box.HOV (attrs, []) -> assert false
- | Box.HOV (attrs, [child]) -> aux_box child
- | Box.HOV (attrs, children) ->
- let spacing = want_spacing attrs in
- let indent = want_indent attrs in
- let spacing_bonus = if spacing then string_space_len else 0 in
- let indent_bonus = if indent then string_indent_len else 0 in
- let sep = if spacing then string_space else "" in
- let fs = List.map aux_box children in
- (fun size ->
- let rows = ref [] in
- let renderings = ref [] in
- let rem_space = ref size in
- let first_row = ref true in
- let use_rendering (space, rendering) =
- let use_indent = !renderings = [] && not !first_row in
- let rendering' =
- if use_indent then List.map indent_string rendering
- else rendering
- in
- renderings := rendering' :: !renderings;
- let bonus = if use_indent then indent_bonus else spacing_bonus in
- rem_space := !rem_space - (space + bonus)
- in
- let end_cluster () =
- let new_rows = merge_columns sep (List.rev !renderings) in
- rows := List.rev_append new_rows !rows;
- rem_space := size - indent_bonus;
- renderings := [];
- first_row := false
- in
- List.iter
- (fun f ->
- let (best_space, _) as best = f max_size in
- if best_space <= !rem_space then
- use_rendering best
- else begin
- end_cluster ();
- if best_space <= !rem_space then use_rendering best
- else use_rendering (f size)
- end)
- fs;
- if !renderings <> [] then end_cluster ();
- max_len !rows, List.rev !rows)
- and aux_mpres =
- let text s = Pres.Mtext ([], s) in
- let mrow c = Pres.Mrow ([], c) in
- function
- | Pres.Mi (_, s)
- | Pres.Mn (_, s)
- | Pres.Mtext (_, s)
- | Pres.Ms (_, s)
- | Pres.Mgliph (_, s) -> fixed_rendering s
- | Pres.Mo (_, s) ->
- let s =
- if String.length s > 1 then
- (* heuristic to guess which operators need to be expanded in their
- * TeX like format *)
- Utf8Macro.tex_of_unicode s ^ " "
- else s
- in
- fixed_rendering s
- | Pres.Mspace _ -> fixed_rendering string_space
- | Pres.Mrow (attrs, children) ->
- let children' = List.map aux_mpres children in
- (fun size -> render_row size false children')
- | Pres.Mfrac (_, m, n) ->
- aux_mpres (mrow [ text "\\frac("; text ")"; text "("; n; text ")" ])
- | Pres.Msqrt (_, m) -> aux_mpres (mrow [ text "\\sqrt("; m; text ")" ])
- | Pres.Mroot (_, r, i) ->
- aux_mpres (mrow [
- text "\\root("; i; text ")"; text "\\of("; r; text ")" ])
- | Pres.Mstyle (_, m)
- | Pres.Merror (_, m)
- | Pres.Mpadded (_, m)
- | Pres.Mphantom (_, m)
- | Pres.Menclose (_, m) -> aux_mpres m
- | Pres.Mfenced (_, children) -> aux_mpres (mrow children)
- | Pres.Maction (_, []) -> assert false
- | Pres.Msub (_, m, n) ->
- aux_mpres (mrow [ text "("; m; text ")\\sub("; n; text ")" ])
- | Pres.Msup (_, m, n) ->
- aux_mpres (mrow [ text "("; m; text ")\\sup("; n; text ")" ])
- | Pres.Munder (_, m, n) ->
- aux_mpres (mrow [ text "("; m; text ")\\below("; n; text ")" ])
- | Pres.Mover (_, m, n) ->
- aux_mpres (mrow [ text "("; m; text ")\\above("; n; text ")" ])
- | Pres.Msubsup _
- | Pres.Munderover _
- | Pres.Mtable _ ->
- prerr_endline
- "MathML presentation element not yet available in concrete syntax";
- assert false
- | Pres.Maction (_, hd :: _) -> aux_mpres hd
- | Pres.Mobject (_, o) -> aux_box (o: CicNotationPres.boxml_markup)
- in
- snd (aux_mpres markup size)
-
-let render_to_string size markup =
- String.concat "\n" (render_to_strings size markup)
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
- (** @return rows list of rows *)
-val render_to_strings: int -> CicNotationPres.markup -> string list
-
- (** helper function
- * @return s, concatenation of the return value of render_to_strings above
- * with newlines as separators *)
-val render_to_string: int -> CicNotationPres.markup -> string
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open GrafiteAst
-
-type notation_id =
- | RuleId of CicNotationParser.rule_id
- | InterpretationId of CicNotationRew.interpretation_id
- | PrettyPrinterId of CicNotationRew.pretty_printer_id
-
-let process_notation st =
- match st with
- | Notation (loc, dir, l1, associativity, precedence, l2) ->
- let rule_id =
- if dir <> Some `RightToLeft then
- [ RuleId (CicNotationParser.extend l1 ?precedence ?associativity
- (fun env loc -> CicNotationFwd.instantiate_level2 env l2)) ]
- else
- []
- in
- let pp_id =
- if dir <> Some `LeftToRight then
- [ PrettyPrinterId
- (CicNotationRew.add_pretty_printer ?precedence ?associativity
- l2 l1) ]
- else
- []
- in
- st, rule_id @ pp_id
- | Interpretation (loc, dsc, l2, l3) ->
- let interp_id = CicNotationRew.add_interpretation dsc l2 l3 in
- st, [ InterpretationId interp_id ]
- | st -> st, []
-
-let remove_notation = function
- | RuleId id -> CicNotationParser.delete id
- | PrettyPrinterId id -> CicNotationRew.remove_pretty_printer id
- | InterpretationId id -> CicNotationRew.remove_interpretation id
-
-let load_notation fname =
- let ic = open_in fname in
- let lexbuf = Ulexing.from_utf8_channel ic in
- try
- while true do
- match GrafiteParser.parse_statement lexbuf with
- | Executable (_, Command (_, cmd)) -> ignore (process_notation cmd)
- | _ -> ()
- done
- with End_of_file -> close_in ic
-
-let get_all_notations () =
- List.map
- (fun (interp_id, dsc) ->
- InterpretationId interp_id, "interpretation: " ^ dsc)
- (CicNotationRew.get_all_interpretations ())
-
-let get_active_notations () =
- List.map (fun id -> InterpretationId id)
- (CicNotationRew.get_active_interpretations ())
-
-let set_active_notations ids =
- let interp_ids =
- HExtlib.filter_map
- (function InterpretationId interp_id -> Some interp_id | _ -> None)
- ids
- in
- CicNotationRew.set_active_interpretations interp_ids
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-type notation_id
-
-val process_notation:
- ('a, 'b) GrafiteAst.command -> ('a, 'b) GrafiteAst.command * notation_id list
-
-val remove_notation: notation_id -> unit
-
-(** @param fname file from which load notation *)
-val load_notation: string -> unit
-
-(** {2 Notation enabling/disabling}
- * Right now, only disabling of notation during pretty printing is supporting.
- * If it is useful to disable it also for the input phase is still to be
- * understood ... *)
-
-val get_all_notations: unit -> (notation_id * string) list (* id, dsc *)
-val get_active_notations: unit -> notation_id list
-val set_active_notations: notation_id list -> unit
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-module Ast = CicNotationPt
-
-type value =
- | TermValue of Ast.term
- | StringValue of string
- | NumValue of string
- | OptValue of value option
- | ListValue of value list
-
-type value_type =
- | TermType
- | StringType
- | NumType
- | OptType of value_type
- | ListType of value_type
-
-exception Value_not_found of string
-exception Type_mismatch of string * value_type
-
-type declaration = string * value_type
-type binding = string * (value_type * value)
-type t = binding list
-
-let lookup env name =
- try
- List.assoc name env
- with Not_found -> raise (Value_not_found name)
-
-let lookup_value env name =
- try
- snd (List.assoc name env)
- with Not_found -> raise (Value_not_found name)
-
-let remove_name env name = List.remove_assoc name env
-
-let remove_names env names =
- List.filter (fun name, _ -> not (List.mem name names)) env
-
-let lookup_term env name =
- match lookup env name with
- | _, TermValue x -> x
- | ty, _ -> raise (Type_mismatch (name, ty))
-
-let lookup_num env name =
- match lookup env name with
- | _, NumValue x -> x
- | ty, _ -> raise (Type_mismatch (name, ty))
-
-let lookup_string env name =
- match lookup env name with
- | _, StringValue x -> x
- | ty, _ -> raise (Type_mismatch (name, ty))
-
-let lookup_opt env name =
- match lookup env name with
- | _, OptValue x -> x
- | ty, _ -> raise (Type_mismatch (name, ty))
-
-let lookup_list env name =
- match lookup env name with
- | _, ListValue x -> x
- | ty, _ -> raise (Type_mismatch (name, ty))
-
-let opt_binding_some (n, (ty, v)) = (n, (OptType ty, OptValue (Some v)))
-let opt_binding_none (n, (ty, v)) = (n, (OptType ty, OptValue None))
-let opt_binding_of_name (n, ty) = (n, (OptType ty, OptValue None))
-let list_binding_of_name (n, ty) = (n, (ListType ty, ListValue []))
-let opt_declaration (n, ty) = (n, OptType ty)
-let list_declaration (n, ty) = (n, ListType ty)
-
-let declaration_of_var = function
- | Ast.NumVar s -> s, NumType
- | Ast.IdentVar s -> s, StringType
- | Ast.TermVar s -> s, TermType
- | _ -> assert false
-
-let value_of_term = function
- | Ast.Num (s, _) -> NumValue s
- | Ast.Ident (s, None) -> StringValue s
- | t -> TermValue t
-
-let term_of_value = function
- | NumValue s -> Ast.Num (s, 0)
- | StringValue s -> Ast.Ident (s, None)
- | TermValue t -> t
- | _ -> assert false (* TO BE UNDERSTOOD *)
-
-let rec well_typed ty value =
- match ty, value with
- | TermType, TermValue _
- | StringType, StringValue _
- | OptType _, OptValue None
- | NumType, NumValue _ -> true
- | OptType ty', OptValue (Some value') -> well_typed ty' value'
- | ListType ty', ListValue vl ->
- List.for_all (fun value' -> well_typed ty' value') vl
- | _ -> false
-
-let declarations_of_env = List.map (fun (name, (ty, _)) -> (name, ty))
-let declarations_of_term p =
- List.map declaration_of_var (CicNotationUtil.variables_of_term p)
-
-let rec combine decls values =
- match decls, values with
- | [], [] -> []
- | (name, ty) :: decls, v :: values ->
- (name, (ty, v)) :: (combine decls values)
- | _ -> assert false
-
-let coalesce_env declarations env_list =
- let env0 = List.map list_binding_of_name declarations in
- let grow_env_entry env n v =
- List.map
- (function
- | (n', (ty, ListValue vl)) as entry ->
- if n' = n then n', (ty, ListValue (v :: vl)) else entry
- | _ -> assert false)
- env
- in
- let grow_env env_i env =
- List.fold_left
- (fun env (n, (_, v)) -> grow_env_entry env n v)
- env env_i
- in
- List.fold_right grow_env env_list env0
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(** {2 Types} *)
-
-type value =
- | TermValue of CicNotationPt.term
- | StringValue of string
- | NumValue of string
- | OptValue of value option
- | ListValue of value list
-
-type value_type =
- | TermType
- | StringType
- | NumType
- | OptType of value_type
- | ListType of value_type
-
- (** looked up value not found in environment *)
-exception Value_not_found of string
-
- (** looked up value has the wrong type
- * parameters are value name and value type in environment *)
-exception Type_mismatch of string * value_type
-
-type declaration = string * value_type
-type binding = string * (value_type * value)
-type t = binding list
-
-val declaration_of_var: CicNotationPt.pattern_variable -> declaration
-val value_of_term: CicNotationPt.term -> value
-val term_of_value: value -> CicNotationPt.term
-val well_typed: value_type -> value -> bool
-
-val declarations_of_env: t -> declaration list
-val declarations_of_term: CicNotationPt.term -> declaration list
-val combine: declaration list -> value list -> t (** @raise Invalid_argument *)
-
-(** {2 Environment lookup} *)
-
-val lookup_value: t -> string -> value (** @raise Value_not_found *)
-
-(** lookup_* functions below may raise Value_not_found and Type_mismatch *)
-
-val lookup_term: t -> string -> CicNotationPt.term
-val lookup_string: t -> string -> string
-val lookup_num: t -> string -> string
-val lookup_opt: t -> string -> value option
-val lookup_list: t -> string -> value list
-
-val remove_name: t -> string -> t
-val remove_names: t -> string list -> t
-
-(** {2 Bindings mangling} *)
-
-val opt_binding_some: binding -> binding (* v -> Some v *)
-val opt_binding_none: binding -> binding (* v -> None *)
-
-val opt_binding_of_name: declaration -> binding (* None binding *)
-val list_binding_of_name: declaration -> binding (* [] binding *)
-
-val opt_declaration: declaration -> declaration (* t -> OptType t *)
-val list_declaration: declaration -> declaration (* t -> ListType t *)
-
-(** given a list of environments bindings a set of names n_1, ..., n_k, returns
- * a single environment where n_i is bound to the list of values bound in the
- * starting environments *)
-val coalesce_env: declaration list -> t list -> t
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Printf
-
-module Ast = CicNotationPt
-module Env = CicNotationEnv
-
-let unopt_names names env =
- let rec aux acc = function
- | (name, (ty, v)) :: tl when List.mem name names ->
- (match ty, v with
- | Env.OptType ty, Env.OptValue (Some v) ->
- aux ((name, (ty, v)) :: acc) tl
- | _ -> assert false)
- | hd :: tl -> aux (hd :: acc) tl
- | [] -> acc
- in
- aux [] env
-
-let head_names names env =
- let rec aux acc = function
- | (name, (ty, v)) :: tl when List.mem name names ->
- (match ty, v with
- | Env.ListType ty, Env.ListValue (v :: _) ->
- aux ((name, (ty, v)) :: acc) tl
- | _ -> assert false)
- | _ :: tl -> aux acc tl
- (* base pattern may contain only meta names, thus we trash all others *)
- | [] -> acc
- in
- aux [] env
-
-let tail_names names env =
- let rec aux acc = function
- | (name, (ty, v)) :: tl when List.mem name names ->
- (match ty, v with
- | Env.ListType ty, Env.ListValue (_ :: vtl) ->
- aux ((name, (Env.ListType ty, Env.ListValue vtl)) :: acc) tl
- | _ -> assert false)
- | binding :: tl -> aux (binding :: acc) tl
- | [] -> acc
- in
- aux [] env
-
-let instantiate_level2 env term =
- let fresh_env = ref [] in
- let lookup_fresh_name n =
- try
- List.assoc n !fresh_env
- with Not_found ->
- let new_name = CicNotationUtil.fresh_name () in
- fresh_env := (n, new_name) :: !fresh_env;
- new_name
- in
- let rec aux env term =
-(* prerr_endline ("ENV " ^ CicNotationPp.pp_env env); *)
- match term with
- | Ast.AttributedTerm (_, term) -> aux env term
- | Ast.Appl terms -> Ast.Appl (List.map (aux env) terms)
- | Ast.Binder (binder, var, body) ->
- Ast.Binder (binder, aux_capture_var env var, aux env body)
- | Ast.Case (term, indty, outty_opt, patterns) ->
- Ast.Case (aux env term, indty, aux_opt env outty_opt,
- List.map (aux_branch env) patterns)
- | Ast.LetIn (var, t1, t2) ->
- Ast.LetIn (aux_capture_var env var, aux env t1, aux env t2)
- | Ast.LetRec (kind, definitions, body) ->
- Ast.LetRec (kind, List.map (aux_definition env) definitions,
- aux env body)
- | Ast.Uri (name, None) -> Ast.Uri (name, None)
- | Ast.Uri (name, Some substs) ->
- Ast.Uri (name, Some (aux_substs env substs))
- | Ast.Ident (name, Some substs) ->
- Ast.Ident (name, Some (aux_substs env substs))
- | Ast.Meta (index, substs) -> Ast.Meta (index, aux_meta_substs env substs)
-
- | Ast.Implicit
- | Ast.Ident _
- | Ast.Num _
- | Ast.Sort _
- | Ast.Symbol _
- | Ast.UserInput -> term
-
- | Ast.Magic magic -> aux_magic env magic
- | Ast.Variable var -> aux_variable env var
-
- | _ -> assert false
- and aux_opt env = function
- | Some term -> Some (aux env term)
- | None -> None
- and aux_capture_var env (name, ty_opt) = (aux env name, aux_opt env ty_opt)
- and aux_branch env (pattern, term) =
- (aux_pattern env pattern, aux env term)
- and aux_pattern env (head, hrefs, vars) =
- (head, hrefs, List.map (aux_capture_var env) vars)
- and aux_definition env (var, term, i) =
- (aux_capture_var env var, aux env term, i)
- and aux_substs env substs =
- List.map (fun (name, term) -> (name, aux env term)) substs
- and aux_meta_substs env meta_substs = List.map (aux_opt env) meta_substs
- and aux_variable env = function
- | Ast.NumVar name -> Ast.Num (Env.lookup_num env name, 0)
- | Ast.IdentVar name -> Ast.Ident (Env.lookup_string env name, None)
- | Ast.TermVar name -> Env.lookup_term env name
- | Ast.FreshVar name -> Ast.Ident (lookup_fresh_name name, None)
- | Ast.Ascription (term, name) -> assert false
- and aux_magic env = function
- | Ast.Default (some_pattern, none_pattern) ->
- let some_pattern_names = CicNotationUtil.names_of_term some_pattern in
- let none_pattern_names = CicNotationUtil.names_of_term none_pattern in
- let opt_names =
- List.filter
- (fun name -> not (List.mem name none_pattern_names))
- some_pattern_names
- in
- (match opt_names with
- | [] -> assert false (* some pattern must contain at least 1 name *)
- | (name :: _) as names ->
- (match Env.lookup_value env name with
- | Env.OptValue (Some _) ->
- (* assumption: if "name" above is bound to Some _, then all
- * names returned by "meta_names_of" are bound to Some _ as well
- *)
- aux (unopt_names names env) some_pattern
- | Env.OptValue None -> aux env none_pattern
- | _ ->
- prerr_endline (sprintf
- "lookup of %s in env %s did not return an optional value"
- name (CicNotationPp.pp_env env));
- assert false))
- | Ast.Fold (`Left, base_pattern, names, rec_pattern) ->
- let acc_name = List.hd names in (* names can't be empty, cfr. parser *)
- let meta_names =
- List.filter ((<>) acc_name)
- (CicNotationUtil.names_of_term rec_pattern)
- in
- (match meta_names with
- | [] -> assert false (* as above *)
- | (name :: _) as names ->
- let rec instantiate_fold_left acc env' =
- match Env.lookup_value env' name with
- | Env.ListValue (_ :: _) ->
- instantiate_fold_left
- (let acc_binding =
- acc_name, (Env.TermType, Env.TermValue acc)
- in
- aux (acc_binding :: head_names names env') rec_pattern)
- (tail_names names env')
- | Env.ListValue [] -> acc
- | _ -> assert false
- in
- instantiate_fold_left (aux env base_pattern) env)
- | Ast.Fold (`Right, base_pattern, names, rec_pattern) ->
- let acc_name = List.hd names in (* names can't be empty, cfr. parser *)
- let meta_names =
- List.filter ((<>) acc_name)
- (CicNotationUtil.names_of_term rec_pattern)
- in
- (match meta_names with
- | [] -> assert false (* as above *)
- | (name :: _) as names ->
- let rec instantiate_fold_right env' =
- match Env.lookup_value env' name with
- | Env.ListValue (_ :: _) ->
- let acc = instantiate_fold_right (tail_names names env') in
- let acc_binding =
- acc_name, (Env.TermType, Env.TermValue acc)
- in
- aux (acc_binding :: head_names names env') rec_pattern
- | Env.ListValue [] -> aux env base_pattern
- | _ -> assert false
- in
- instantiate_fold_right env)
- | Ast.If (_, p_true, p_false) as t ->
- aux env (CicNotationUtil.find_branch (Ast.Magic t))
- | Ast.Fail -> assert false
- | _ -> assert false
- in
- aux env term
-
-let instantiate_appl_pattern env appl_pattern =
- let lookup name =
- try List.assoc name env
- with Not_found ->
- prerr_endline (sprintf "Name %s not found" name);
- assert false
- in
- let rec aux = function
- | Ast.UriPattern uri -> CicUtil.term_of_uri uri
- | Ast.ImplicitPattern -> Cic.Implicit None
- | Ast.VarPattern name -> lookup name
- | Ast.ApplPattern terms -> Cic.Appl (List.map aux terms)
- in
- aux appl_pattern
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
- (** fills a term pattern instantiating variable magics *)
-val instantiate_level2:
- CicNotationEnv.t -> CicNotationPt.term ->
- CicNotationPt.term
-
- (** @param env environment from argument_pattern to cic terms
- * @param pat cic_appl_pattern *)
-val instantiate_appl_pattern:
- (string * Cic.term) list -> CicNotationPt.cic_appl_pattern ->
- Cic.term
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Printf
-
-exception Error of int * int * string
-
-let regexp number = xml_digit+
-
- (* ZACK: breaks unicode's binder followed by an ascii letter without blank *)
-(* let regexp ident_letter = xml_letter *)
-
-let regexp ident_letter = [ 'a' - 'z' 'A' - 'Z' ]
-
- (* must be in sync with "is_ligature_char" below *)
-let regexp ligature_char = [ "'`~!?@*()[]<>-+=|:;.,/\"" ]
-let regexp ligature = ligature_char ligature_char+
-
-let is_ligature_char =
- (* must be in sync with "regexp ligature_char" above *)
- let chars = "'`~!?@*()[]<>-+=|:;.,/\"" in
- (fun char ->
- (try
- ignore (String.index chars char);
- true
- with Not_found -> false))
-
-let regexp ident_decoration = '\'' | '?' | '`'
-let regexp ident_cont = ident_letter | xml_digit | '_'
-let regexp ident = ident_letter ident_cont* ident_decoration*
-
-let regexp tex_token = '\\' ident
-
-let regexp delim_begin = "\\["
-let regexp delim_end = "\\]"
-
-let regexp qkeyword = "'" ident "'"
-
-let regexp implicit = '?'
-let regexp placeholder = '%'
-let regexp meta = implicit number
-
-let regexp csymbol = '\'' ident
-
-let regexp begin_group = "@{" | "${"
-let regexp end_group = '}'
-let regexp wildcard = "$_"
-let regexp ast_ident = "@" ident
-let regexp ast_csymbol = "@" csymbol
-let regexp meta_ident = "$" ident
-let regexp meta_anonymous = "$_"
-let regexp qstring = '"' [^ '"']* '"'
-
-let regexp begincomment = "(**" xml_blank
-let regexp beginnote = "(*"
-let regexp endcomment = "*)"
-(* let regexp comment_char = [^'*'] | '*'[^')']
-let regexp note = "|+" ([^'*'] | "**") comment_char* "+|" *)
-
-let level1_layouts =
- [ "sub"; "sup";
- "below"; "above";
- "over"; "atop"; "frac";
- "sqrt"; "root"
- ]
-
-let level1_keywords =
- [ "hbox"; "hvbox"; "hovbox"; "vbox";
- "break";
- "list0"; "list1"; "sep";
- "opt";
- "term"; "ident"; "number"
- ] @ level1_layouts
-
-let level2_meta_keywords =
- [ "if"; "then"; "else";
- "fold"; "left"; "right"; "rec";
- "fail";
- "default";
- "anonymous"; "ident"; "number"; "term"; "fresh"
- ]
-
- (* (string, unit) Hashtbl.t, to exploit multiple bindings *)
-let level2_ast_keywords = Hashtbl.create 23
-let _ =
- List.iter (fun k -> Hashtbl.add level2_ast_keywords k ())
- [ "CProp"; "Prop"; "Type"; "Set"; "let"; "rec"; "corec"; "match";
- "with"; "in"; "and"; "to"; "as"; "on"; "return" ]
-
-let add_level2_ast_keyword k = Hashtbl.add level2_ast_keywords k ()
-let remove_level2_ast_keyword k = Hashtbl.remove level2_ast_keywords k
-
- (* (string, int) Hashtbl.t, with multiple bindings.
- * int is the unicode codepoint *)
-let ligatures = Hashtbl.create 23
-let _ =
- List.iter
- (fun (ligature, symbol) -> Hashtbl.add ligatures ligature symbol)
- [ ("->", <:unicode<to>>); ("=>", <:unicode<Rightarrow>>);
- ("<=", <:unicode<leq>>); (">=", <:unicode<geq>>);
- ("<>", <:unicode<neq>>); (":=", <:unicode<def>>);
- ]
-
-let regexp uri_step = [ 'a' - 'z' 'A' - 'Z' '0' - '9' '_' '-' ]+
-
-let regexp uri =
- ("cic:/" | "theory:/") (* schema *)
-(* ident ('/' ident)* |+ path +| *)
- uri_step ('/' uri_step)* (* path *)
- ('.' ident)+ (* ext *)
- ("#xpointer(" number ('/' number)+ ")")? (* xpointer *)
-
-let error lexbuf msg =
- let begin_cnum, end_cnum = Ulexing.loc lexbuf in
- raise (Error (begin_cnum, end_cnum, msg))
-let error_at_end lexbuf msg =
- let begin_cnum, end_cnum = Ulexing.loc lexbuf in
- raise (Error (begin_cnum, end_cnum, msg))
-
-let return_with_loc token begin_cnum end_cnum =
- (* TODO handle line/column numbers *)
- let flocation_begin =
- { Lexing.pos_fname = "";
- Lexing.pos_lnum = -1; Lexing.pos_bol = -1;
- Lexing.pos_cnum = begin_cnum }
- in
- let flocation_end = { flocation_begin with Lexing.pos_cnum = end_cnum } in
- (token, (flocation_begin, flocation_end))
-
-let return lexbuf token =
- let begin_cnum, end_cnum = Ulexing.loc lexbuf in
- return_with_loc token begin_cnum end_cnum
-
-let return_lexeme lexbuf name = return lexbuf (name, Ulexing.utf8_lexeme lexbuf)
-
-let return_symbol lexbuf s = return lexbuf ("SYMBOL", s)
-let return_eoi lexbuf = return lexbuf ("EOI", "")
-
-let remove_quotes s = String.sub s 1 (String.length s - 2)
-
-let mk_lexer token =
- let tok_func stream =
-(* let lexbuf = Ulexing.from_utf8_stream stream in *)
-(** XXX Obj.magic rationale.
- * The problem.
- * camlp4 constraints the tok_func field of Token.glexer to have type:
- * Stream.t char -> (Stream.t 'te * flocation_function)
- * In order to use ulex we have (in theory) to instantiate a new lexbuf each
- * time a char Stream.t is passed, destroying the previous lexbuf which may
- * have consumed a character from the old stream which is lost forever :-(
- * The "solution".
- * Instead of passing to camlp4 a char Stream.t we pass a lexbuf, casting it to
- * char Stream.t with Obj.magic where needed.
- *)
- let lexbuf = Obj.magic stream in
- Token.make_stream_and_flocation
- (fun () ->
- try
- token lexbuf
- with
- | Ulexing.Error -> error_at_end lexbuf "Unexpected character"
- | Ulexing.InvalidCodepoint p ->
- error_at_end lexbuf (sprintf "Invalid code point: %d" p))
- in
- {
- Token.tok_func = tok_func;
- Token.tok_using = (fun _ -> ());
- Token.tok_removing = (fun _ -> ());
- Token.tok_match = Token.default_match;
- Token.tok_text = Token.lexer_text;
- Token.tok_comm = None;
- }
-
-let expand_macro lexbuf =
- let macro =
- Ulexing.utf8_sub_lexeme lexbuf 1 (Ulexing.lexeme_length lexbuf - 1)
- in
- try
- ("SYMBOL", Utf8Macro.expand macro)
- with Utf8Macro.Macro_not_found _ -> "SYMBOL", Ulexing.utf8_lexeme lexbuf
-
-let remove_quotes s = String.sub s 1 (String.length s - 2)
-let remove_left_quote s = String.sub s 1 (String.length s - 1)
-
-let rec level2_pattern_token_group counter buffer =
- lexer
- | end_group ->
- if (counter > 0) then
- Buffer.add_string buffer (Ulexing.utf8_lexeme lexbuf) ;
- snd (Ulexing.loc lexbuf)
- | begin_group ->
- Buffer.add_string buffer (Ulexing.utf8_lexeme lexbuf) ;
- ignore (level2_pattern_token_group (counter + 1) buffer lexbuf) ;
- level2_pattern_token_group counter buffer lexbuf
- | _ ->
- Buffer.add_string buffer (Ulexing.utf8_lexeme lexbuf) ;
- level2_pattern_token_group counter buffer lexbuf
-
-let read_unparsed_group token_name lexbuf =
- let buffer = Buffer.create 16 in
- let begin_cnum, _ = Ulexing.loc lexbuf in
- let end_cnum = level2_pattern_token_group 0 buffer lexbuf in
- return_with_loc (token_name, Buffer.contents buffer) begin_cnum end_cnum
-
-let rec level2_meta_token =
- lexer
- | xml_blank+ -> level2_meta_token lexbuf
- | ident ->
- let s = Ulexing.utf8_lexeme lexbuf in
- begin
- if List.mem s level2_meta_keywords then
- return lexbuf ("", s)
- else
- return lexbuf ("IDENT", s)
- end
- | "@{" -> read_unparsed_group "UNPARSED_AST" lexbuf
- | ast_ident ->
- return lexbuf ("UNPARSED_AST",
- remove_left_quote (Ulexing.utf8_lexeme lexbuf))
- | ast_csymbol ->
- return lexbuf ("UNPARSED_AST",
- remove_left_quote (Ulexing.utf8_lexeme lexbuf))
- | eof -> return_eoi lexbuf
-
-let rec comment_token acc depth =
- lexer
- | beginnote ->
- let acc = acc ^ Ulexing.utf8_lexeme lexbuf in
- comment_token acc (depth + 1) lexbuf
- | endcomment ->
- let acc = acc ^ Ulexing.utf8_lexeme lexbuf in
- if depth = 0
- then acc
- else comment_token acc (depth - 1) lexbuf
- | _ ->
- let acc = acc ^ Ulexing.utf8_lexeme lexbuf in
- comment_token acc depth lexbuf
-
- (** @param k continuation to be invoked when no ligature has been found *)
-let rec ligatures_token k =
- lexer
- | ligature ->
- let lexeme = Ulexing.utf8_lexeme lexbuf in
- (match List.rev (Hashtbl.find_all ligatures lexeme) with
- | [] -> (* ligature not found, rollback and try default lexer *)
- Ulexing.rollback lexbuf;
- k lexbuf
- | default_lig :: _ -> (* ligatures found, use the default one *)
- return_symbol lexbuf default_lig)
- | eof -> return_eoi lexbuf
- | _ -> (* not a ligature, rollback and try default lexer *)
- Ulexing.rollback lexbuf;
- k lexbuf
-
-and level2_ast_token =
- lexer
- | xml_blank+ -> ligatures_token level2_ast_token lexbuf
- | meta -> return lexbuf ("META", Ulexing.utf8_lexeme lexbuf)
- | implicit -> return lexbuf ("IMPLICIT", "")
- | placeholder -> return lexbuf ("PLACEHOLDER", "")
- | ident ->
- let lexeme = Ulexing.utf8_lexeme lexbuf in
- if Hashtbl.mem level2_ast_keywords lexeme then
- return lexbuf ("", lexeme)
- else
- return lexbuf ("IDENT", lexeme)
- | number -> return lexbuf ("NUMBER", Ulexing.utf8_lexeme lexbuf)
- | tex_token -> return lexbuf (expand_macro lexbuf)
- | uri -> return lexbuf ("URI", Ulexing.utf8_lexeme lexbuf)
- | qstring ->
- return lexbuf ("QSTRING", remove_quotes (Ulexing.utf8_lexeme lexbuf))
- | csymbol ->
- return lexbuf ("CSYMBOL", remove_left_quote (Ulexing.utf8_lexeme lexbuf))
- | "${" -> read_unparsed_group "UNPARSED_META" lexbuf
- | "@{" -> read_unparsed_group "UNPARSED_AST" lexbuf
- | '(' -> return lexbuf ("LPAREN", "")
- | ')' -> return lexbuf ("RPAREN", "")
- | meta_ident ->
- return lexbuf ("UNPARSED_META",
- remove_left_quote (Ulexing.utf8_lexeme lexbuf))
- | meta_anonymous -> return lexbuf ("UNPARSED_META", "anonymous")
- | beginnote ->
- let comment = comment_token (Ulexing.utf8_lexeme lexbuf) 0 lexbuf in
-(* let comment =
- Ulexing.utf8_sub_lexeme lexbuf 2 (Ulexing.lexeme_length lexbuf - 4)
- in
- return lexbuf ("NOTE", comment) *)
- ligatures_token level2_ast_token lexbuf
- | begincomment -> return lexbuf ("BEGINCOMMENT","")
- | endcomment -> return lexbuf ("ENDCOMMENT","")
- | eof -> return_eoi lexbuf
- | _ -> return_symbol lexbuf (Ulexing.utf8_lexeme lexbuf)
-
-and level1_pattern_token =
- lexer
- | xml_blank+ -> ligatures_token level1_pattern_token lexbuf
- | number -> return lexbuf ("NUMBER", Ulexing.utf8_lexeme lexbuf)
- | ident ->
- let s = Ulexing.utf8_lexeme lexbuf in
- begin
- if List.mem s level1_keywords then
- return lexbuf ("", s)
- else
- return lexbuf ("IDENT", s)
- end
- | tex_token -> return lexbuf (expand_macro lexbuf)
- | qkeyword ->
- return lexbuf ("QKEYWORD", remove_quotes (Ulexing.utf8_lexeme lexbuf))
- | '(' -> return lexbuf ("LPAREN", "")
- | ')' -> return lexbuf ("RPAREN", "")
- | eof -> return_eoi lexbuf
- | _ -> return_symbol lexbuf (Ulexing.utf8_lexeme lexbuf)
-
-let level1_pattern_token = ligatures_token level1_pattern_token
-let level2_ast_token = ligatures_token level2_ast_token
-
-(* API implementation *)
-
-let level1_pattern_lexer = mk_lexer level1_pattern_token
-let level2_ast_lexer = mk_lexer level2_ast_token
-let level2_meta_lexer = mk_lexer level2_meta_token
-
-let lookup_ligatures lexeme =
- try
- if lexeme.[0] = '\\'
- then [ Utf8Macro.expand (String.sub lexeme 1 (String.length lexeme - 1)) ]
- else List.rev (Hashtbl.find_all ligatures lexeme)
- with Invalid_argument _ | Utf8Macro.Macro_not_found _ as exn -> []
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
- (** begin of error offset (counted in unicode codepoint)
- * end of error offset (counted as above)
- * error message *)
-exception Error of int * int * string
-
- (** XXX ZACK DEFCON 4 BEGIN: never use the tok_func field of the glexers below
- * passing values of type char Stream.t, they should be in fact Ulexing.lexbuf
- * casted with Obj.magic :-/ Read the comment in the .ml for the rationale *)
-
-val level1_pattern_lexer: (string * string) Token.glexer
-val level2_ast_lexer: (string * string) Token.glexer
-val level2_meta_lexer: (string * string) Token.glexer
-
- (** XXX ZACK DEFCON 4 END *)
-
-val add_level2_ast_keyword: string -> unit (** non idempotent *)
-val remove_level2_ast_keyword: string -> unit (** non idempotent *)
-
-(** {2 Ligatures} *)
-
-val is_ligature_char: char -> bool
-val lookup_ligatures: string -> string list
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Printf
-
-module Ast = CicNotationPt
-module Env = CicNotationEnv
-module Pp = CicNotationPp
-module Util = CicNotationUtil
-
-type pattern_id = int
-
-exception No_match
-
-module OrderedInt =
-struct
- type t = int
- let compare (x1:t) (x2:t) = Pervasives.compare x2 x1 (* reverse order *)
-end
-
-module IntSet = Set.Make (OrderedInt)
-
-let int_set_of_int_list l =
- List.fold_left (fun acc i -> IntSet.add i acc) IntSet.empty l
-
-type pattern_kind = Variable | Constructor
-type tag_t = int
-
-module type PATTERN =
-sig
- type pattern_t
- type term_t
- val classify : pattern_t -> pattern_kind
- val tag_of_pattern : pattern_t -> tag_t * pattern_t list
- val tag_of_term : term_t -> tag_t * term_t list
- val string_of_term: term_t -> string
- val string_of_pattern: pattern_t -> string
-end
-
-module Matcher (P: PATTERN) =
-struct
- type row_t = P.pattern_t list * P.pattern_t list * pattern_id
- type t = row_t list
-
- let compatible p1 p2 = P.classify p1 = P.classify p2
-
- let matched = List.map (fun (matched, _, pid) -> matched, pid)
-
- let partition t pidl =
- let partitions = Hashtbl.create 11 in
- let add pid row = Hashtbl.add partitions pid row in
- (try
- List.iter2 add pidl t
- with Invalid_argument _ -> assert false);
- let pidset = int_set_of_int_list pidl in
- IntSet.fold
- (fun pid acc ->
- match Hashtbl.find_all partitions pid with
- | [] -> acc
- | patterns -> (pid, List.rev patterns) :: acc)
- pidset []
-
- let are_empty t =
- match t with
- | (_, [], _) :: _ -> true
- (* if first row has an empty list of patterns, then others have as well *)
- | _ -> false
-
- (* return 2 lists of rows, first one containing homogeneous rows according
- * to "compatible" below *)
- let horizontal_split t =
- let ap, first_row, t', first_row_class =
- match t with
- | [] -> assert false
- | (_, [], _) :: _ ->
- assert false (* are_empty should have been invoked in advance *)
- | ((_, hd :: _ , _) as row) :: tl -> hd, row, tl, P.classify hd
- in
- let rec aux prev_t = function
- | [] -> List.rev prev_t, []
- | (_, [], _) :: _ -> assert false
- | ((_, hd :: _, _) as row) :: tl when compatible ap hd ->
- aux (row :: prev_t) tl
- | t -> List.rev prev_t, t
- in
- let rows1, rows2 = aux [first_row] t' in
- first_row_class, rows1, rows2
-
- (* return 2 lists, first one representing first column, second one
- * representing a new pattern matrix where matched patterns have been moved
- * to decl *)
- let vertical_split t =
- List.map
- (function
- | decls, hd :: tl, pid -> hd :: decls, tl, pid
- | _ -> assert false)
- t
-
- let variable_closure ksucc =
- (fun matched_terms constructors terms ->
-(* prerr_endline "variable_closure"; *)
- match terms with
- | hd :: tl -> ksucc (hd :: matched_terms) constructors tl
- | _ -> assert false)
-
- let success_closure ksucc =
- (fun matched_terms constructors terms ->
-(* prerr_endline "success_closure"; *)
- ksucc matched_terms constructors)
-
- let constructor_closure ksuccs =
- (fun matched_terms constructors terms ->
-(* prerr_endline "constructor_closure"; *)
- match terms with
- | t :: tl ->
- (try
- let tag, subterms = P.tag_of_term t in
- let constructors' =
- if subterms = [] then t :: constructors else constructors
- in
- let k' = List.assoc tag ksuccs in
- k' matched_terms constructors' (subterms @ tl)
- with Not_found -> None)
- | [] -> assert false)
-
- let backtrack_closure ksucc kfail =
- (fun matched_terms constructors terms ->
-(* prerr_endline "backtrack_closure"; *)
- match ksucc matched_terms constructors terms with
- | Some x -> Some x
- | None -> kfail matched_terms constructors terms)
-
- let compiler rows match_cb fail_k =
- let rec aux t =
- if t = [] then
- (fun _ _ _ -> fail_k ())
- else if are_empty t then
- success_closure (match_cb (matched t))
- else
- match horizontal_split t with
- | _, [], _ -> assert false
- | Variable, t', [] -> variable_closure (aux (vertical_split t'))
- | Constructor, t', [] ->
- let tagl =
- List.map
- (function
- | _, p :: _, _ -> fst (P.tag_of_pattern p)
- | _ -> assert false)
- t'
- in
- let clusters = partition t' tagl in
- let ksuccs =
- List.map
- (fun (tag, cluster) ->
- let cluster' =
- List.map (* add args as patterns heads *)
- (function
- | matched_p, p :: tl, pid ->
- let _, subpatterns = P.tag_of_pattern p in
- matched_p, subpatterns @ tl, pid
- | _ -> assert false)
- cluster
- in
- tag, aux cluster')
- clusters
- in
- constructor_closure ksuccs
- | _, t', t'' -> backtrack_closure (aux t') (aux t'')
- in
- let t = List.map (fun (p, pid) -> [], [p], pid) rows in
- let matcher = aux t in
- (fun term -> matcher [] [] [term])
-end
-
-module Matcher21 =
-struct
- module Pattern21 =
- struct
- type pattern_t = Ast.term
- type term_t = Ast.term
- let rec classify = function
- | Ast.AttributedTerm (_, t) -> classify t
- | Ast.Variable _ -> Variable
- | Ast.Magic _
- | Ast.Layout _
- | Ast.Literal _ as t -> assert false
- | _ -> Constructor
- let tag_of_pattern = CicNotationTag.get_tag
- let tag_of_term t = CicNotationTag.get_tag t
- let string_of_term = CicNotationPp.pp_term
- let string_of_pattern = CicNotationPp.pp_term
- end
-
- module M = Matcher (Pattern21)
-
- let extract_magic term =
- let magic_map = ref [] in
- let add_magic m =
- let name = Util.fresh_name () in
- magic_map := (name, m) :: !magic_map;
- Ast.Variable (Ast.TermVar name)
- in
- let rec aux = function
- | Ast.AttributedTerm (_, t) -> assert false
- | Ast.Literal _
- | Ast.Layout _ -> assert false
- | Ast.Variable v -> Ast.Variable v
- | Ast.Magic m -> add_magic m
- | t -> Util.visit_ast aux t
- in
- let term' = aux term in
- term', !magic_map
-
- let env_of_matched pl tl =
- try
- List.map2
- (fun p t ->
- match p, t with
- Ast.Variable (Ast.TermVar name), _ ->
- name, (Env.TermType, Env.TermValue t)
- | Ast.Variable (Ast.NumVar name), (Ast.Num (s, _)) ->
- name, (Env.NumType, Env.NumValue s)
- | Ast.Variable (Ast.IdentVar name), (Ast.Ident (s, None)) ->
- name, (Env.StringType, Env.StringValue s)
- | _ -> assert false)
- pl tl
- with Invalid_argument _ -> assert false
-
- let rec compiler rows =
- let rows', magic_maps =
- List.split
- (List.map
- (fun (p, pid) ->
- let p', map = extract_magic p in
- (p', pid), (pid, map))
- rows)
- in
- let magichecker map =
- List.fold_left
- (fun f (name, m) ->
- let m_checker = compile_magic m in
- (fun env ctors ->
- match m_checker (Env.lookup_term env name) env ctors with
- | None -> None
- | Some (env, ctors) -> f env ctors))
- (fun env ctors -> Some (env, ctors))
- map
- in
- let magichooser candidates =
- List.fold_left
- (fun f (pid, pl, checker) ->
- (fun matched_terms constructors ->
- let env = env_of_matched pl matched_terms in
- match checker env constructors with
- | None -> f matched_terms constructors
- | Some (env, ctors') ->
- let magic_map =
- try List.assoc pid magic_maps with Not_found -> assert false
- in
- let env' = Env.remove_names env (List.map fst magic_map) in
- Some (env', ctors', pid)))
- (fun _ _ -> None)
- (List.rev candidates)
- in
- let match_cb rows =
- let candidates =
- List.map
- (fun (pl, pid) ->
- let magic_map =
- try List.assoc pid magic_maps with Not_found -> assert false
- in
- pid, pl, magichecker magic_map)
- rows
- in
- magichooser candidates
- in
- M.compiler rows' match_cb (fun _ -> None)
-
- and compile_magic = function
- | Ast.Fold (kind, p_base, names, p_rec) ->
- let p_rec_decls = Env.declarations_of_term p_rec in
- (* LUCA: p_rec_decls should not contain "names" *)
- let acc_name = try List.hd names with Failure _ -> assert false in
- let compiled_base = compiler [p_base, 0]
- and compiled_rec = compiler [p_rec, 0] in
- (fun term env ctors ->
- let aux_base term =
- match compiled_base term with
- | None -> None
- | Some (env', ctors', _) -> Some (env', ctors', [])
- in
- let rec aux term =
- match compiled_rec term with
- | None -> aux_base term
- | Some (env', ctors', _) ->
- begin
- let acc = Env.lookup_term env' acc_name in
- let env'' = Env.remove_name env' acc_name in
- match aux acc with
- | None -> aux_base term
- | Some (base_env, ctors', rec_envl) ->
- let ctors'' = ctors' @ ctors in
- Some (base_env, ctors'',env'' :: rec_envl)
- end
- in
- match aux term with
- | None -> None
- | Some (base_env, ctors, rec_envl) ->
- let env' =
- base_env @ Env.coalesce_env p_rec_decls rec_envl @ env
- (* @ env LUCA!!! *)
- in
- Some (env', ctors))
-
- | Ast.Default (p_some, p_none) -> (* p_none can't bound names *)
- let p_some_decls = Env.declarations_of_term p_some in
- let p_none_decls = Env.declarations_of_term p_none in
- let p_opt_decls =
- List.filter
- (fun decl -> not (List.mem decl p_none_decls))
- p_some_decls
- in
- let none_env = List.map Env.opt_binding_of_name p_opt_decls in
- let compiled = compiler [p_some, 0] in
- (fun term env ctors ->
- match compiled term with
- | None -> Some (none_env, ctors) (* LUCA: @ env ??? *)
- | Some (env', ctors', 0) ->
- let env' =
- List.map
- (fun (name, (ty, v)) as binding ->
- if List.exists (fun (name', _) -> name = name') p_opt_decls
- then Env.opt_binding_some binding
- else binding)
- env'
- in
- Some (env' @ env, ctors' @ ctors)
- | _ -> assert false)
-
- | Ast.If (p_test, p_true, p_false) ->
- let compiled_test = compiler [p_test, 0]
- and compiled_true = compiler [p_true, 0]
- and compiled_false = compiler [p_false, 0] in
- (fun term env ctors ->
- let branch =
- match compiled_test term with
- | None -> compiled_false
- | Some _ -> compiled_true
- in
- match branch term with
- | None -> None
- | Some (env', ctors', _) -> Some (env' @ env, ctors' @ ctors))
-
- | Ast.Fail -> (fun _ _ _ -> None)
-
- | _ -> assert false
-end
-
-module Matcher32 =
-struct
- module Pattern32 =
- struct
- type cic_mask_t =
- Blob
- | Uri of UriManager.uri
- | Appl of cic_mask_t list
-
- let uri_of_term t = CicUtil.uri_of_term (Deannotate.deannotate_term t)
-
- let mask_of_cic = function
- | Cic.AAppl (_, tl) -> Appl (List.map (fun _ -> Blob) tl), tl
- | Cic.AConst (_, _, [])
- | Cic.AVar (_, _, [])
- | Cic.AMutInd (_, _, _, [])
- | Cic.AMutConstruct (_, _, _, _, []) as t -> Uri (uri_of_term t), []
- | _ -> Blob, []
-
- let tag_of_term t =
- let mask, tl = mask_of_cic t in
- Hashtbl.hash mask, tl
-
- let mask_of_appl_pattern = function
- | Ast.UriPattern uri -> Uri uri, []
- | Ast.ImplicitPattern
- | Ast.VarPattern _ -> Blob, []
- | Ast.ApplPattern pl -> Appl (List.map (fun _ -> Blob) pl), pl
-
- let tag_of_pattern p =
- let mask, pl = mask_of_appl_pattern p in
- Hashtbl.hash mask, pl
-
- type pattern_t = Ast.cic_appl_pattern
- type term_t = Cic.annterm
-
- let string_of_pattern = GrafiteAstPp.pp_cic_appl_pattern
- let string_of_term t = CicPp.ppterm (Deannotate.deannotate_term t)
-
- let classify = function
- | Ast.ImplicitPattern
- | Ast.VarPattern _ -> Variable
- | Ast.UriPattern _
- | Ast.ApplPattern _ -> Constructor
- end
-
- module M = Matcher (Pattern32)
-
- let compiler rows =
- let match_cb rows =
- let pl, pid = try List.hd rows with Not_found -> assert false in
- (fun matched_terms constructors ->
- let env =
- try
- List.map2
- (fun p t ->
- match p with
- | Ast.ImplicitPattern -> Util.fresh_name (), t
- | Ast.VarPattern name -> name, t
- | _ -> assert false)
- pl matched_terms
- with Invalid_argument _ -> assert false
- in
- Some (env, constructors, pid))
- in
- M.compiler rows match_cb (fun () -> None)
-end
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-type pattern_kind = Variable | Constructor
-type tag_t = int
-
-module type PATTERN =
-sig
- type pattern_t
- type term_t
-
- val classify : pattern_t -> pattern_kind
- val tag_of_pattern : pattern_t -> tag_t * pattern_t list
- val tag_of_term : term_t -> tag_t * term_t list
-
- (** {3 Debugging} *)
- val string_of_term: term_t -> string
- val string_of_pattern: pattern_t -> string
-end
-
-module Matcher (P: PATTERN) :
-sig
- (** @param patterns pattern matrix (pairs <pattern, pattern_id>)
- * @param success_cb callback invoked in case of matching.
- * Its argument are the list of pattern who matches the input term, the list
- * of terms bound in them, the list of terms which matched constructors.
- * Its return value is Some _ if the matching is valid, None otherwise; the
- * latter kind of return value will trigger backtracking in the pattern
- * matching algorithm
- * @param failure_cb callback invoked in case of matching failure
- * @param term term on which pattern match on *)
- val compiler:
- (P.pattern_t * int) list ->
- ((P.pattern_t list * int) list -> P.term_t list -> P.term_t list ->
- 'a option) -> (* terms *) (* constructors *)
- (unit -> 'a option) ->
- (P.term_t -> 'a option)
-end
-
-module Matcher21:
-sig
- (** @param l2_patterns level 2 (AST) patterns *)
- val compiler :
- (CicNotationPt.term * int) list ->
- (CicNotationPt.term ->
- (CicNotationEnv.t * CicNotationPt.term list * int) option)
-end
-
-module Matcher32:
-sig
- (** @param l3_patterns level 3 (CIC) patterns (AKA cic_appl_pattern) *)
- val compiler :
- (CicNotationPt.cic_appl_pattern * int) list ->
- (Cic.annterm ->
- ((string * Cic.annterm) list * Cic.annterm list * int) option)
-end
-
+++ /dev/null
-(* *)(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-oopen Printf
-mmodule Ast = CicNotationPtmmodule Env = CicNotationEnv
-eexception Parse_error of Token.flocation * stringeexception Level_not_found of int
-llet level1_pattern_grammar =
- Grammar.gcreate CicNotationLexer.level1_pattern_lexerllet level2_ast_grammar = Grammar.gcreate CicNotationLexer.level2_ast_lexerllet level2_meta_grammar = Grammar.gcreate CicNotationLexer.level2_meta_lexer
-llet min_precedence = 0llet max_precedence = 100
-llet level1_pattern =
- Grammar.Entry.create level1_pattern_grammar "level1_pattern"llet level2_ast = Grammar.Entry.create level2_ast_grammar "level2_ast"llet term = Grammar.Entry.create level2_ast_grammar "term"llet let_defs = Grammar.Entry.create level2_ast_grammar "let_defs"llet level2_meta = Grammar.Entry.create level2_meta_grammar "level2_meta"
-llet return_term loc term = ()
-llet int_of_string s =
- try Pervasives.int_of_string s with
- Failure _ ->
- failwith (sprintf "Lexer failure: string_of_int \"%s\" failed" s)
-(** {2 Grammar extension} *)
-
-llet gram_symbol s = Gramext.Stoken ("SYMBOL", s)llet gram_ident s = Gramext.Stoken ("IDENT", s)llet gram_number s = Gramext.Stoken ("NUMBER", s)llet gram_keyword s = Gramext.Stoken ("", s)llet gram_term = Gramext.Sself
-llet gram_of_literal =
- function
- `Symbol s -> gram_symbol s
- | `Keyword s -> gram_keyword s
- | `Number s -> gram_number s
-ttype binding =
- NoBinding
- | Binding of string * Env.value_type
- | Env of (string * Env.value_type) list
-llet make_action action bindings =
- let rec aux (vl : CicNotationEnv.t) =
- function
- [] -> Gramext.action (fun (loc : Ast.location) -> action vl loc)
- | NoBinding :: tl -> Gramext.action (fun _ -> aux vl tl)
- | Binding (name, Env.TermType) :: tl ->
- Gramext.action
- (fun (v : Ast.term) ->
- aux ((name, (Env.TermType, Env.TermValue v)) :: vl) tl)
- | Binding (name, Env.StringType) :: tl ->
- Gramext.action
- (fun (v : string) ->
- aux ((name, (Env.StringType, Env.StringValue v)) :: vl) tl)
- | Binding (name, Env.NumType) :: tl ->
- Gramext.action
- (fun (v : string) ->
- aux ((name, (Env.NumType, Env.NumValue v)) :: vl) tl)
- | Binding (name, Env.OptType t) :: tl ->
- Gramext.action
- (fun (v : 'a option) ->
- aux ((name, (Env.OptType t, Env.OptValue v)) :: vl) tl)
- | Binding (name, Env.ListType t) :: tl ->
- Gramext.action
- (fun (v : 'a list) ->
- aux ((name, (Env.ListType t, Env.ListValue v)) :: vl) tl)
- | Env _ :: tl ->
- Gramext.action (fun (v : CicNotationEnv.t) -> aux (v @ vl) tl)
- in
- aux [] (List.rev bindings)
-llet flatten_opt =
- let rec aux acc =
- function
- [] -> List.rev acc
- | NoBinding :: tl -> aux acc tl
- | Env names :: tl -> aux (List.rev names @ acc) tl
- | Binding (name, ty) :: tl -> aux ((name, ty) :: acc) tl
- in
- aux []
- (* given a level 1 pattern computes the new RHS of "term" grammar entry *)
-llet extract_term_production pattern =
- let rec aux =
- function
- Ast.AttributedTerm (_, t) -> aux t
- | Ast.Literal l -> aux_literal l
- | Ast.Layout l -> aux_layout l
- | Ast.Magic m -> aux_magic m
- | Ast.Variable v -> aux_variable v
- | t -> prerr_endline (CicNotationPp.pp_term t); assert false
- and aux_literal =
- function
- `Symbol s -> [NoBinding, gram_symbol s]
- | `Keyword s -> [NoBinding, gram_keyword s]
- | `Number s -> [NoBinding, gram_number s]
- and aux_layout =
- function
- Ast.Sub (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\sub"] @ aux p2
- | Ast.Sup (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\sup"] @ aux p2
- | Ast.Below (p1, p2) ->
- aux p1 @ [NoBinding, gram_symbol "\\below"] @ aux p2
- | Ast.Above (p1, p2) ->
- aux p1 @ [NoBinding, gram_symbol "\\above"] @ aux p2
- | Ast.Frac (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\frac"] @ aux p2
- | Ast.Atop (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\atop"] @ aux p2
- | Ast.Over (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\over"] @ aux p2
- | Ast.Root (p1, p2) ->
- [NoBinding, gram_symbol "\\root"] @ aux p2 @
- [NoBinding, gram_symbol "\\of"] @ aux p1
- | Ast.Sqrt p -> [NoBinding, gram_symbol "\\sqrt"] @ aux p
- | Ast.Break -> []
- | Ast.Box (_, pl) -> List.flatten (List.map aux pl)
- | Ast.Group pl -> List.flatten (List.map aux pl)
- and aux_magic magic =
- match magic with
- Ast.Opt p ->
- let (p_bindings, p_atoms, p_names, p_action) = inner_pattern p in
- let action (env_opt : CicNotationEnv.t option) (loc : Ast.location) =
- match env_opt with
- Some env -> List.map Env.opt_binding_some env
- | None -> List.map Env.opt_binding_of_name p_names
- in
- [Env (List.map Env.opt_declaration p_names),
- Gramext.srules
- [[Gramext.Sopt (Gramext.srules [p_atoms, p_action])],
- Gramext.action action]]
- | Ast.List0 (p, _) | Ast.List1 (p, _) ->
- let (p_bindings, p_atoms, p_names, p_action) = inner_pattern p in
- let action (env_list : CicNotationEnv.t list) (loc : Ast.location) =
- CicNotationEnv.coalesce_env p_names env_list
- in
- let gram_of_list s =
- match magic with
- Ast.List0 (_, None) -> Gramext.Slist0 s
- | Ast.List1 (_, None) -> Gramext.Slist1 s
- | Ast.List0 (_, Some l) -> Gramext.Slist0sep (s, gram_of_literal l)
- | Ast.List1 (_, Some l) -> Gramext.Slist1sep (s, gram_of_literal l)
- | _ -> assert false
- in
- [Env (List.map Env.list_declaration p_names),
- Gramext.srules
- [[gram_of_list (Gramext.srules [p_atoms, p_action])],
- Gramext.action action]]
- | _ -> assert false
- and aux_variable =
- function
- Ast.NumVar s -> [Binding (s, Env.NumType), gram_number ""]
- | Ast.TermVar s -> [Binding (s, Env.TermType), gram_term]
- | Ast.IdentVar s -> [Binding (s, Env.StringType), gram_ident ""]
- | Ast.Ascription (p, s) -> assert false
- | Ast.FreshVar _ -> assert false
- and inner_pattern p =
- let (p_bindings, p_atoms) = List.split (aux p) in
- let p_names = flatten_opt p_bindings in
- let action =
- make_action (fun (env : CicNotationEnv.t) (loc : Ast.location) -> env)
- p_bindings
- in
- p_bindings, p_atoms, p_names, action
- in
- aux pattern
-
-let level_of precedence associativity =
- if precedence < min_precedence || precedence > max_precedence then
- raise (Level_not_found precedence);
- let assoc_string =
- match associativity with
- Gramext.NonA -> "N"
- | Gramext.LeftA -> "L"
- | Gramext.RightA -> "R"
- in
- string_of_int precedence ^ assoc_string
-
-type rule_id = Token.t Gramext.g_symbol list
-
- (* mapping: rule_id -> owned keywords. (rule_id, string list) Hashtbl.t *)
-let owned_keywords = Hashtbl.create 23
-
-let extend level1_pattern ~precedence ~associativity action =
- let (p_bindings, p_atoms) =
- List.split (extract_term_production level1_pattern)
- in
- let level = level_of precedence associativity in
- let p_names = flatten_opt p_bindings in
- let _ =
- Grammar.extend
- [Grammar.Entry.obj (term : 'a Grammar.Entry.e),
- Some (Gramext.Level level),
- [None, Some associativity,
- [p_atoms,
- make_action
- (fun (env : CicNotationEnv.t) (loc : Ast.location) ->
- action env loc)
- p_bindings]]]
- in
- let keywords = CicNotationUtil.keywords_of_term level1_pattern in
- let rule_id = p_atoms in
- List.iter CicNotationLexer.add_level2_ast_keyword keywords;
- Hashtbl.add owned_keywords rule_id keywords;
- rule_id
-
-let delete rule_id =
- let atoms = rule_id in
- begin try
- let keywords = Hashtbl.find owned_keywords rule_id in
- List.iter CicNotationLexer.remove_level2_ast_keyword keywords
- with
- Not_found -> assert false
- end;
- Grammar.delete_rule term atoms
-
-(** {2 Grammar} *)
-
-let parse_level1_pattern_ref = ref (fun _ -> assert false)
-let parse_level2_ast_ref = ref (fun _ -> assert false)
-let parse_level2_meta_ref = ref (fun _ -> assert false)
-
-let fold_cluster binder terms ty body =
- List.fold_right (fun term body -> Ast.Binder (binder, (term, ty), body))
- terms body (* terms are names: either Ident or FreshVar *)
-
-let fold_exists terms ty body =
- List.fold_right
- (fun term body ->
- let lambda = Ast.Binder (`Lambda, (term, ty), body) in
- Ast.Appl [Ast.Symbol ("exists", 0); lambda])
- terms body
-
-let fold_binder binder pt_names body =
- List.fold_right (fun (names, ty) body -> fold_cluster binder names ty body)
- pt_names body
-
-let return_term loc term = Ast.AttributedTerm (`Loc loc, term)
-
- (* create empty precedence level for "term" *)
-let _ =
- let dummy_action =
- Gramext.action
- (fun _ -> failwith "internal error, lexer generated a dummy token")
- in
- let dummy_prod = [[Gramext.Stoken ("DUMMY", "")], dummy_action] in
- let mk_level_list first last =
- let rec aux acc =
- function
- i when i < first -> acc
- | i ->
- aux
- ((Some (string_of_int i ^ "N"), Some Gramext.NonA, dummy_prod) ::
- (Some (string_of_int i ^ "L"), Some Gramext.LeftA,
- dummy_prod) ::
- (Some (string_of_int i ^ "R"), Some Gramext.RightA,
- dummy_prod) ::
- acc)
- (i - 1)
- in
- aux [] last
- in
- Grammar.extend
- [Grammar.Entry.obj (term : 'a Grammar.Entry.e), None,
- mk_level_list min_precedence max_precedence]
-
-(* {{{ Grammar for concrete syntax patterns, notation level 1 *)
-let _ =
- Grammar.extend
- (let _ = (level1_pattern : 'level1_pattern Grammar.Entry.e) in
- let grammar_entry_create s =
- Grammar.Entry.create (Grammar.of_entry level1_pattern) s
- in
- let l1_pattern : 'l1_pattern Grammar.Entry.e =
- grammar_entry_create "l1_pattern"
- and literal : 'literal Grammar.Entry.e = grammar_entry_create "literal"
- and sep : 'sep Grammar.Entry.e = grammar_entry_create "sep"
- and l1_magic_pattern : 'l1_magic_pattern Grammar.Entry.e =
- grammar_entry_create "l1_magic_pattern"
- and l1_pattern_variable : 'l1_pattern_variable Grammar.Entry.e =
- grammar_entry_create "l1_pattern_variable"
- and l1_simple_pattern : 'l1_simple_pattern Grammar.Entry.e =
- grammar_entry_create "l1_simple_pattern"
- in
- [Grammar.Entry.obj (level1_pattern : 'level1_pattern Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (l1_pattern : 'l1_pattern Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (p : 'l1_pattern)
- (loc : Lexing.position * Lexing.position) ->
- (CicNotationUtil.boxify p : 'level1_pattern))]];
- Grammar.Entry.obj (l1_pattern : 'l1_pattern Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Slist1
- (Gramext.Snterm
- (Grammar.Entry.obj
- (l1_simple_pattern : 'l1_simple_pattern Grammar.Entry.e)))],
- Gramext.action
- (fun (p : 'l1_simple_pattern list)
- (loc : Lexing.position * Lexing.position) ->
- (p : 'l1_pattern))]];
- Grammar.Entry.obj (literal : 'literal Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("NUMBER", "")],
- Gramext.action
- (fun (n : string) (loc : Lexing.position * Lexing.position) ->
- (`Number n : 'literal));
- [Gramext.Stoken ("QKEYWORD", "")],
- Gramext.action
- (fun (k : string) (loc : Lexing.position * Lexing.position) ->
- (`Keyword k : 'literal));
- [Gramext.Stoken ("SYMBOL", "")],
- Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (`Symbol s : 'literal))]];
- Grammar.Entry.obj (sep : 'sep Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "sep");
- Gramext.Snterm
- (Grammar.Entry.obj (literal : 'literal Grammar.Entry.e))],
- Gramext.action
- (fun (sep : 'literal) _ (loc : Lexing.position * Lexing.position) ->
- (sep : 'sep))]];
- Grammar.Entry.obj
- (l1_magic_pattern : 'l1_magic_pattern Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "opt");
- Gramext.Snterm
- (Grammar.Entry.obj
- (l1_simple_pattern : 'l1_simple_pattern Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'l1_simple_pattern) _
- (loc : Lexing.position * Lexing.position) ->
- (Ast.Opt p : 'l1_magic_pattern));
- [Gramext.Stoken ("", "list1");
- Gramext.Snterm
- (Grammar.Entry.obj
- (l1_simple_pattern : 'l1_simple_pattern Grammar.Entry.e));
- Gramext.Sopt
- (Gramext.Snterm (Grammar.Entry.obj (sep : 'sep Grammar.Entry.e)))],
- Gramext.action
- (fun (sep : 'sep option) (p : 'l1_simple_pattern) _
- (loc : Lexing.position * Lexing.position) ->
- (Ast.List1 (p, sep) : 'l1_magic_pattern));
- [Gramext.Stoken ("", "list0");
- Gramext.Snterm
- (Grammar.Entry.obj
- (l1_simple_pattern : 'l1_simple_pattern Grammar.Entry.e));
- Gramext.Sopt
- (Gramext.Snterm (Grammar.Entry.obj (sep : 'sep Grammar.Entry.e)))],
- Gramext.action
- (fun (sep : 'sep option) (p : 'l1_simple_pattern) _
- (loc : Lexing.position * Lexing.position) ->
- (Ast.List0 (p, sep) : 'l1_magic_pattern))]];
- Grammar.Entry.obj
- (l1_pattern_variable : 'l1_pattern_variable Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "ident"); Gramext.Stoken ("IDENT", "")],
- Gramext.action
- (fun (id : string) _ (loc : Lexing.position * Lexing.position) ->
- (Ast.IdentVar id : 'l1_pattern_variable));
- [Gramext.Stoken ("", "number"); Gramext.Stoken ("IDENT", "")],
- Gramext.action
- (fun (id : string) _ (loc : Lexing.position * Lexing.position) ->
- (Ast.NumVar id : 'l1_pattern_variable));
- [Gramext.Stoken ("", "term"); Gramext.Stoken ("IDENT", "")],
- Gramext.action
- (fun (id : string) _ (loc : Lexing.position * Lexing.position) ->
- (Ast.TermVar id : 'l1_pattern_variable))]];
- Grammar.Entry.obj
- (l1_simple_pattern : 'l1_simple_pattern Grammar.Entry.e),
- None,
- [Some "layout", Some Gramext.LeftA,
- [[Gramext.Stoken ("LPAREN", "");
- Gramext.Snterm
- (Grammar.Entry.obj (l1_pattern : 'l1_pattern Grammar.Entry.e));
- Gramext.Stoken ("RPAREN", "")],
- Gramext.action
- (fun _ (p : 'l1_pattern) _
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (CicNotationUtil.group p) :
- 'l1_simple_pattern));
- [Gramext.Stoken ("", "break")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Layout Ast.Break) : 'l1_simple_pattern));
- [Gramext.Stoken ("", "hovbox"); Gramext.Stoken ("LPAREN", "");
- Gramext.Snterm
- (Grammar.Entry.obj (l1_pattern : 'l1_pattern Grammar.Entry.e));
- Gramext.Stoken ("RPAREN", "")],
- Gramext.action
- (fun _ (p : 'l1_pattern) _ _
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc
- (Ast.Layout (Ast.Box ((Ast.HOV, false, false), p))) :
- 'l1_simple_pattern));
- [Gramext.Stoken ("", "hvbox"); Gramext.Stoken ("LPAREN", "");
- Gramext.Snterm
- (Grammar.Entry.obj (l1_pattern : 'l1_pattern Grammar.Entry.e));
- Gramext.Stoken ("RPAREN", "")],
- Gramext.action
- (fun _ (p : 'l1_pattern) _ _
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc
- (Ast.Layout (Ast.Box ((Ast.HV, false, false), p))) :
- 'l1_simple_pattern));
- [Gramext.Stoken ("", "vbox"); Gramext.Stoken ("LPAREN", "");
- Gramext.Snterm
- (Grammar.Entry.obj (l1_pattern : 'l1_pattern Grammar.Entry.e));
- Gramext.Stoken ("RPAREN", "")],
- Gramext.action
- (fun _ (p : 'l1_pattern) _ _
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc
- (Ast.Layout (Ast.Box ((Ast.V, false, false), p))) :
- 'l1_simple_pattern));
- [Gramext.Stoken ("", "hbox"); Gramext.Stoken ("LPAREN", "");
- Gramext.Snterm
- (Grammar.Entry.obj (l1_pattern : 'l1_pattern Grammar.Entry.e));
- Gramext.Stoken ("RPAREN", "")],
- Gramext.action
- (fun _ (p : 'l1_pattern) _ _
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc
- (Ast.Layout (Ast.Box ((Ast.H, false, false), p))) :
- 'l1_simple_pattern));
- [Gramext.Stoken ("SYMBOL", "\\root"); Gramext.Sself;
- Gramext.Stoken ("SYMBOL", "\\of"); Gramext.Sself],
- Gramext.action
- (fun (arg : 'l1_simple_pattern) _ (index : 'l1_simple_pattern) _
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Layout (Ast.Root (arg, index))) :
- 'l1_simple_pattern));
- [Gramext.Stoken ("SYMBOL", "\\sqrt"); Gramext.Sself],
- Gramext.action
- (fun (p : 'l1_simple_pattern) _
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Layout (Ast.Sqrt p)) :
- 'l1_simple_pattern));
- [Gramext.Stoken ("SYMBOL", "\\frac"); Gramext.Sself; Gramext.Sself],
- Gramext.action
- (fun (p2 : 'l1_simple_pattern) (p1 : 'l1_simple_pattern) _
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Layout (Ast.Frac (p1, p2))) :
- 'l1_simple_pattern));
- [Gramext.Sself; Gramext.Stoken ("SYMBOL", "\\atop"); Gramext.Sself],
- Gramext.action
- (fun (p2 : 'l1_simple_pattern) _ (p1 : 'l1_simple_pattern)
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Layout (Ast.Atop (p1, p2))) :
- 'l1_simple_pattern));
- [Gramext.Sself; Gramext.Stoken ("SYMBOL", "\\over"); Gramext.Sself],
- Gramext.action
- (fun (p2 : 'l1_simple_pattern) _ (p1 : 'l1_simple_pattern)
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Layout (Ast.Over (p1, p2))) :
- 'l1_simple_pattern));
- [Gramext.Sself; Gramext.Stoken ("SYMBOL", "\\above"); Gramext.Sself],
- Gramext.action
- (fun (p2 : 'l1_simple_pattern) _ (p1 : 'l1_simple_pattern)
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Layout (Ast.Above (p1, p2))) :
- 'l1_simple_pattern));
- [Gramext.Sself; Gramext.Stoken ("SYMBOL", "\\below"); Gramext.Sself],
- Gramext.action
- (fun (p2 : 'l1_simple_pattern) _ (p1 : 'l1_simple_pattern)
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Layout (Ast.Below (p1, p2))) :
- 'l1_simple_pattern));
- [Gramext.Sself; Gramext.Stoken ("SYMBOL", "\\sup"); Gramext.Sself],
- Gramext.action
- (fun (p2 : 'l1_simple_pattern) _ (p1 : 'l1_simple_pattern)
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Layout (Ast.Sup (p1, p2))) :
- 'l1_simple_pattern));
- [Gramext.Sself; Gramext.Stoken ("SYMBOL", "\\sub"); Gramext.Sself],
- Gramext.action
- (fun (p2 : 'l1_simple_pattern) _ (p1 : 'l1_simple_pattern)
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Layout (Ast.Sub (p1, p2))) :
- 'l1_simple_pattern))];
- Some "simple", Some Gramext.NonA,
- [[Gramext.Snterm
- (Grammar.Entry.obj (literal : 'literal Grammar.Entry.e))],
- Gramext.action
- (fun (l : 'literal) (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Literal l) : 'l1_simple_pattern));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (l1_pattern_variable : 'l1_pattern_variable Grammar.Entry.e))],
- Gramext.action
- (fun (v : 'l1_pattern_variable)
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Variable v) : 'l1_simple_pattern));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (l1_magic_pattern : 'l1_magic_pattern Grammar.Entry.e))],
- Gramext.action
- (fun (m : 'l1_magic_pattern)
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Magic m) : 'l1_simple_pattern));
- [Gramext.Stoken ("IDENT", "")],
- Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Variable (Ast.TermVar i)) :
- 'l1_simple_pattern))]]])
-(* }}} *)
-
-(* {{{ Grammar for ast magics, notation level 2 *)
-let _ =
- Grammar.extend
- (let _ = (level2_meta : 'level2_meta Grammar.Entry.e) in
- let grammar_entry_create s =
- Grammar.Entry.create (Grammar.of_entry level2_meta) s
- in
- let l2_variable : 'l2_variable Grammar.Entry.e =
- grammar_entry_create "l2_variable"
- and l2_magic : 'l2_magic Grammar.Entry.e =
- grammar_entry_create "l2_magic"
- in
- [Grammar.Entry.obj (l2_variable : 'l2_variable Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("IDENT", "")],
- Gramext.action
- (fun (id : string) (loc : Lexing.position * Lexing.position) ->
- (Ast.TermVar id : 'l2_variable));
- [Gramext.Stoken ("", "anonymous")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (Ast.TermVar "_" : 'l2_variable));
- [Gramext.Stoken ("", "fresh"); Gramext.Stoken ("IDENT", "")],
- Gramext.action
- (fun (id : string) _ (loc : Lexing.position * Lexing.position) ->
- (Ast.FreshVar id : 'l2_variable));
- [Gramext.Stoken ("", "ident"); Gramext.Stoken ("IDENT", "")],
- Gramext.action
- (fun (id : string) _ (loc : Lexing.position * Lexing.position) ->
- (Ast.IdentVar id : 'l2_variable));
- [Gramext.Stoken ("", "number"); Gramext.Stoken ("IDENT", "")],
- Gramext.action
- (fun (id : string) _ (loc : Lexing.position * Lexing.position) ->
- (Ast.NumVar id : 'l2_variable));
- [Gramext.Stoken ("", "term"); Gramext.Stoken ("IDENT", "")],
- Gramext.action
- (fun (id : string) _ (loc : Lexing.position * Lexing.position) ->
- (Ast.TermVar id : 'l2_variable))]];
- Grammar.Entry.obj (l2_magic : 'l2_magic Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "fail")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (Ast.Fail : 'l2_magic));
- [Gramext.Stoken ("", "if");
- Gramext.Snterm
- (Grammar.Entry.obj (level2_meta : 'level2_meta Grammar.Entry.e));
- Gramext.Stoken ("", "then");
- Gramext.Snterm
- (Grammar.Entry.obj (level2_meta : 'level2_meta Grammar.Entry.e));
- Gramext.Stoken ("", "else");
- Gramext.Snterm
- (Grammar.Entry.obj (level2_meta : 'level2_meta Grammar.Entry.e))],
- Gramext.action
- (fun (p_false : 'level2_meta) _ (p_true : 'level2_meta) _
- (p_test : 'level2_meta) _
- (loc : Lexing.position * Lexing.position) ->
- (Ast.If (p_test, p_true, p_false) : 'l2_magic));
- [Gramext.Stoken ("", "default");
- Gramext.Snterm
- (Grammar.Entry.obj (level2_meta : 'level2_meta Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (level2_meta : 'level2_meta Grammar.Entry.e))],
- Gramext.action
- (fun (none : 'level2_meta) (some : 'level2_meta) _
- (loc : Lexing.position * Lexing.position) ->
- (Ast.Default (some, none) : 'l2_magic));
- [Gramext.Stoken ("", "fold");
- Gramext.srules
- [[Gramext.Stoken ("", "right")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (`Right : 'e__1));
- [Gramext.Stoken ("", "left")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (`Left : 'e__1))];
- Gramext.Snterm
- (Grammar.Entry.obj (level2_meta : 'level2_meta Grammar.Entry.e));
- Gramext.Stoken ("", "rec"); Gramext.Stoken ("IDENT", "");
- Gramext.Snterm
- (Grammar.Entry.obj (level2_meta : 'level2_meta Grammar.Entry.e))],
- Gramext.action
- (fun (recursive : 'level2_meta) (id : string) _
- (base : 'level2_meta) (kind : 'e__1) _
- (loc : Lexing.position * Lexing.position) ->
- (Ast.Fold (kind, base, [id], recursive) : 'l2_magic))]];
- Grammar.Entry.obj (level2_meta : 'level2_meta Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("UNPARSED_AST", "")],
- Gramext.action
- (fun (blob : string) (loc : Lexing.position * Lexing.position) ->
- (!parse_level2_ast_ref (Ulexing.from_utf8_string blob) :
- 'level2_meta));
- [Gramext.Snterm
- (Grammar.Entry.obj (l2_variable : 'l2_variable Grammar.Entry.e))],
- Gramext.action
- (fun (var : 'l2_variable)
- (loc : Lexing.position * Lexing.position) ->
- (Ast.Variable var : 'level2_meta));
- [Gramext.Snterm
- (Grammar.Entry.obj (l2_magic : 'l2_magic Grammar.Entry.e))],
- Gramext.action
- (fun (magic : 'l2_magic)
- (loc : Lexing.position * Lexing.position) ->
- (Ast.Magic magic : 'level2_meta))]]])
-(* }}} *)
-
-(* {{{ Grammar for ast patterns, notation level 2 *)
-let _ =
- Grammar.extend
- (let _ = (level2_ast : 'level2_ast Grammar.Entry.e)
- and _ = (term : 'term Grammar.Entry.e)
- and _ = (let_defs : 'let_defs Grammar.Entry.e) in
- let grammar_entry_create s =
- Grammar.Entry.create (Grammar.of_entry level2_ast) s
- in
- let sort : 'sort Grammar.Entry.e = grammar_entry_create "sort"
- and explicit_subst : 'explicit_subst Grammar.Entry.e =
- grammar_entry_create "explicit_subst"
- and meta_subst : 'meta_subst Grammar.Entry.e =
- grammar_entry_create "meta_subst"
- and meta_substs : 'meta_substs Grammar.Entry.e =
- grammar_entry_create "meta_substs"
- and possibly_typed_name : 'possibly_typed_name Grammar.Entry.e =
- grammar_entry_create "possibly_typed_name"
- and match_pattern : 'match_pattern Grammar.Entry.e =
- grammar_entry_create "match_pattern"
- and binder : 'binder Grammar.Entry.e = grammar_entry_create "binder"
- and arg : 'arg Grammar.Entry.e = grammar_entry_create "arg"
- and single_arg : 'single_arg Grammar.Entry.e =
- grammar_entry_create "single_arg"
- and induction_kind : 'induction_kind Grammar.Entry.e =
- grammar_entry_create "induction_kind"
- and binder_vars : 'binder_vars Grammar.Entry.e =
- grammar_entry_create "binder_vars"
- in
- [Grammar.Entry.obj (level2_ast : 'level2_ast Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (term : 'term Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'term) (loc : Lexing.position * Lexing.position) ->
- (p : 'level2_ast))]];
- Grammar.Entry.obj (sort : 'sort Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "CProp")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (`CProp : 'sort));
- [Gramext.Stoken ("", "Type")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (`Type : 'sort));
- [Gramext.Stoken ("", "Set")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) -> (`Set : 'sort));
- [Gramext.Stoken ("", "Prop")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (`Prop : 'sort))]];
- Grammar.Entry.obj (explicit_subst : 'explicit_subst Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("SYMBOL", "\\subst"); Gramext.Stoken ("SYMBOL", "[");
- Gramext.Slist1sep
- (Gramext.srules
- [[Gramext.Stoken ("IDENT", "");
- Gramext.Stoken ("SYMBOL", "≔");
- Gramext.Snterm
- (Grammar.Entry.obj (term : 'term Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'term) _ (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (i, t : 'e__2))],
- Gramext.Stoken ("SYMBOL", ";"));
- Gramext.Stoken ("SYMBOL", "]")],
- Gramext.action
- (fun _ (substs : 'e__2 list) _ _
- (loc : Lexing.position * Lexing.position) ->
- (substs : 'explicit_subst))]];
- Grammar.Entry.obj (meta_subst : 'meta_subst Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (term : 'term Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'term) (loc : Lexing.position * Lexing.position) ->
- (Some p : 'meta_subst));
- [Gramext.Stoken ("SYMBOL", "_")],
- Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (None : 'meta_subst))]];
- Grammar.Entry.obj (meta_substs : 'meta_substs Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("SYMBOL", "[");
- Gramext.Slist0
- (Gramext.Snterm
- (Grammar.Entry.obj (meta_subst : 'meta_subst Grammar.Entry.e)));
- Gramext.Stoken ("SYMBOL", "]")],
- Gramext.action
- (fun _ (substs : 'meta_subst list) _
- (loc : Lexing.position * Lexing.position) ->
- (substs : 'meta_substs))]];
- Grammar.Entry.obj
- (possibly_typed_name : 'possibly_typed_name Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (single_arg : 'single_arg Grammar.Entry.e))],
- Gramext.action
- (fun (arg : 'single_arg)
- (loc : Lexing.position * Lexing.position) ->
- (arg, None : 'possibly_typed_name));
- [Gramext.Stoken ("LPAREN", "");
- Gramext.Snterm
- (Grammar.Entry.obj (single_arg : 'single_arg Grammar.Entry.e));
- Gramext.Stoken ("SYMBOL", ":");
- Gramext.Snterm (Grammar.Entry.obj (term : 'term Grammar.Entry.e));
- Gramext.Stoken ("RPAREN", "")],
- Gramext.action
- (fun _ (typ : 'term) _ (id : 'single_arg) _
- (loc : Lexing.position * Lexing.position) ->
- (id, Some typ : 'possibly_typed_name))]];
- Grammar.Entry.obj (match_pattern : 'match_pattern Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("LPAREN", ""); Gramext.Stoken ("IDENT", "");
- Gramext.Slist1
- (Gramext.Snterm
- (Grammar.Entry.obj
- (possibly_typed_name :
- 'possibly_typed_name Grammar.Entry.e)));
- Gramext.Stoken ("RPAREN", "")],
- Gramext.action
- (fun _ (vars : 'possibly_typed_name list) (id : string) _
- (loc : Lexing.position * Lexing.position) ->
- (id, None, vars : 'match_pattern));
- [Gramext.Stoken ("IDENT", "")],
- Gramext.action
- (fun (id : string) (loc : Lexing.position * Lexing.position) ->
- (id, None, [] : 'match_pattern))]];
- Grammar.Entry.obj (binder : 'binder Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("SYMBOL", "λ")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (`Lambda : 'binder));
- [Gramext.Stoken ("SYMBOL", "∀")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (`Forall : 'binder));
- [Gramext.Stoken ("SYMBOL", "Π")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (`Pi : 'binder))]];
- Grammar.Entry.obj (arg : 'arg Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("UNPARSED_META", "")],
- Gramext.action
- (fun (blob : string) (loc : Lexing.position * Lexing.position) ->
- (let meta =
- !parse_level2_meta_ref (Ulexing.from_utf8_string blob)
- in
- match meta with
- Ast.Variable (Ast.FreshVar _) -> [meta], None
- | Ast.Variable (Ast.TermVar "_") ->
- [Ast.Ident ("_", None)], None
- | _ -> failwith "Invalid bound name." :
- 'arg));
- [Gramext.Stoken ("IDENT", "")],
- Gramext.action
- (fun (name : string) (loc : Lexing.position * Lexing.position) ->
- ([Ast.Ident (name, None)], None : 'arg));
- [Gramext.Stoken ("LPAREN", "");
- Gramext.Slist1sep
- (Gramext.Stoken ("IDENT", ""), Gramext.Stoken ("SYMBOL", ","));
- Gramext.Stoken ("SYMBOL", ":");
- Gramext.Snterm (Grammar.Entry.obj (term : 'term Grammar.Entry.e));
- Gramext.Stoken ("RPAREN", "")],
- Gramext.action
- (fun _ (ty : 'term) _ (names : string list) _
- (loc : Lexing.position * Lexing.position) ->
- (List.map (fun n -> Ast.Ident (n, None)) names, Some ty :
- 'arg))]];
- Grammar.Entry.obj (single_arg : 'single_arg Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("UNPARSED_META", "")],
- Gramext.action
- (fun (blob : string) (loc : Lexing.position * Lexing.position) ->
- (let meta =
- !parse_level2_meta_ref (Ulexing.from_utf8_string blob)
- in
- match meta with
- Ast.Variable (Ast.FreshVar _) |
- Ast.Variable (Ast.IdentVar _) ->
- meta
- | Ast.Variable (Ast.TermVar "_") -> Ast.Ident ("_", None)
- | _ -> failwith "Invalid index name." :
- 'single_arg));
- [Gramext.Stoken ("IDENT", "")],
- Gramext.action
- (fun (name : string) (loc : Lexing.position * Lexing.position) ->
- (Ast.Ident (name, None) : 'single_arg))]];
- Grammar.Entry.obj (induction_kind : 'induction_kind Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "corec")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (`CoInductive : 'induction_kind));
- [Gramext.Stoken ("", "rec")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (`Inductive : 'induction_kind))]];
- Grammar.Entry.obj (let_defs : 'let_defs Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Slist1sep
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (single_arg : 'single_arg Grammar.Entry.e));
- Gramext.Slist1
- (Gramext.Snterm
- (Grammar.Entry.obj (arg : 'arg Grammar.Entry.e)));
- Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "on");
- Gramext.Snterm
- (Grammar.Entry.obj
- (single_arg : 'single_arg Grammar.Entry.e))],
- Gramext.action
- (fun (id : 'single_arg) _
- (loc : Lexing.position * Lexing.position) ->
- (id : 'e__3))]);
- Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("SYMBOL", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (term : 'term Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'term) _
- (loc : Lexing.position * Lexing.position) ->
- (p : 'e__4))]);
- Gramext.Stoken ("SYMBOL", "≝");
- Gramext.Snterm
- (Grammar.Entry.obj (term : 'term Grammar.Entry.e))],
- Gramext.action
- (fun (body : 'term) _ (ty : 'e__4 option)
- (index_name : 'e__3 option) (args : 'arg list)
- (name : 'single_arg)
- (loc : Lexing.position * Lexing.position) ->
- (let body = fold_binder `Lambda args body in
- let ty =
- match ty with
- None -> None
- | Some ty -> Some (fold_binder `Pi args ty)
- in
- let rec position_of name p =
- function
- [] -> None, p
- | n :: _ when n = name -> Some p, p
- | _ :: tl -> position_of name (p + 1) tl
- in
- let rec find_arg name n =
- function
- [] ->
- Ast.fail loc
- (sprintf "Argument %s not found"
- (CicNotationPp.pp_term name))
- | (l, _) :: tl ->
- match position_of name 0 l with
- None, len -> find_arg name (n + len) tl
- | Some where, len -> n + where
- in
- let index =
- match index_name with
- None -> 0
- | Some index_name -> find_arg index_name 0 args
- in
- (name, ty), body, index :
- 'e__5))],
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (defs : 'e__5 list)
- (loc : Lexing.position * Lexing.position) ->
- (defs : 'let_defs))]];
- Grammar.Entry.obj (binder_vars : 'binder_vars Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("LPAREN", "");
- Gramext.srules
- [[Gramext.Stoken ("SYMBOL", "_")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- ([Ast.Ident ("_", None)] : 'e__8));
- [Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (single_arg : 'single_arg Grammar.Entry.e)),
- Gramext.Stoken ("SYMBOL", ","))],
- Gramext.action
- (fun (l : 'single_arg list)
- (loc : Lexing.position * Lexing.position) ->
- (l : 'e__8))];
- Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("SYMBOL", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (term : 'term Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'term) _
- (loc : Lexing.position * Lexing.position) ->
- (t : 'e__9))]);
- Gramext.Stoken ("RPAREN", "")],
- Gramext.action
- (fun _ (typ : 'e__9 option) (vars : 'e__8) _
- (loc : Lexing.position * Lexing.position) ->
- (vars, typ : 'binder_vars));
- [Gramext.srules
- [[Gramext.Stoken ("SYMBOL", "_")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- ([Ast.Ident ("_", None)] : 'e__6));
- [Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (single_arg : 'single_arg Grammar.Entry.e)),
- Gramext.Stoken ("SYMBOL", ","))],
- Gramext.action
- (fun (l : 'single_arg list)
- (loc : Lexing.position * Lexing.position) ->
- (l : 'e__6))];
- Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("SYMBOL", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (term : 'term Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'term) _
- (loc : Lexing.position * Lexing.position) ->
- (t : 'e__7))])],
- Gramext.action
- (fun (typ : 'e__7 option) (vars : 'e__6)
- (loc : Lexing.position * Lexing.position) ->
- (vars, typ : 'binder_vars))]];
- Grammar.Entry.obj (term : 'term Grammar.Entry.e),
- Some (Gramext.Level "10N"),
- [None, None,
- [[Gramext.Stoken ("", "let");
- Gramext.Snterm
- (Grammar.Entry.obj
- (induction_kind : 'induction_kind Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (let_defs : 'let_defs Grammar.Entry.e));
- Gramext.Stoken ("", "in"); Gramext.Sself],
- Gramext.action
- (fun (body : 'term) _ (defs : 'let_defs) (k : 'induction_kind) _
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.LetRec (k, defs, body)) : 'term));
- [Gramext.Stoken ("", "let");
- Gramext.Snterm
- (Grammar.Entry.obj
- (possibly_typed_name : 'possibly_typed_name Grammar.Entry.e));
- Gramext.Stoken ("SYMBOL", "≝"); Gramext.Sself;
- Gramext.Stoken ("", "in"); Gramext.Sself],
- Gramext.action
- (fun (p2 : 'term) _ (p1 : 'term) _ (var : 'possibly_typed_name) _
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.LetIn (var, p1, p2)) : 'term))]];
- Grammar.Entry.obj (term : 'term Grammar.Entry.e),
- Some (Gramext.Level "20R"),
- [None, None,
- [[Gramext.Stoken ("SYMBOL", "∃");
- Gramext.Snterm
- (Grammar.Entry.obj (binder_vars : 'binder_vars Grammar.Entry.e));
- Gramext.Stoken ("SYMBOL", "."); Gramext.Sself],
- Gramext.action
- (fun (body : 'term) _ (vars, typ : 'binder_vars) _
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (fold_exists vars typ body) : 'term));
- [Gramext.Snterm
- (Grammar.Entry.obj (binder : 'binder Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (binder_vars : 'binder_vars Grammar.Entry.e));
- Gramext.Stoken ("SYMBOL", "."); Gramext.Sself],
- Gramext.action
- (fun (body : 'term) _ (vars, typ : 'binder_vars) (b : 'binder)
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (fold_cluster b vars typ body) : 'term))]];
- Grammar.Entry.obj (term : 'term Grammar.Entry.e),
- Some (Gramext.Level "70L"),
- [None, None,
- [[Gramext.Sself; Gramext.Sself],
- Gramext.action
- (fun (p2 : 'term) (p1 : 'term)
- (loc : Lexing.position * Lexing.position) ->
- (let rec aux =
- function
- Ast.Appl (hd :: tl) |
- Ast.AttributedTerm (_, Ast.Appl (hd :: tl)) ->
- aux hd @ tl
- | term -> [term]
- in
- return_term loc (Ast.Appl (aux p1 @ [p2])) :
- 'term))]];
- Grammar.Entry.obj (term : 'term Grammar.Entry.e),
- Some (Gramext.Level "90N"),
- [None, None,
- [[Gramext.Stoken ("UNPARSED_META", "")],
- Gramext.action
- (fun (blob : string) (loc : Lexing.position * Lexing.position) ->
- (!parse_level2_meta_ref (Ulexing.from_utf8_string blob) :
- 'term));
- [Gramext.Stoken ("LPAREN", ""); Gramext.Sself;
- Gramext.Stoken ("RPAREN", "")],
- Gramext.action
- (fun _ (p : 'term) _ (loc : Lexing.position * Lexing.position) ->
- (p : 'term));
- [Gramext.Stoken ("LPAREN", ""); Gramext.Sself;
- Gramext.Stoken ("SYMBOL", ":"); Gramext.Sself;
- Gramext.Stoken ("RPAREN", "")],
- Gramext.action
- (fun _ (p2 : 'term) _ (p1 : 'term) _
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Cast (p1, p2)) : 'term));
- [Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("SYMBOL", "[");
- Gramext.Snterm
- (Grammar.Entry.obj (term : 'term Grammar.Entry.e));
- Gramext.Stoken ("SYMBOL", "]")],
- Gramext.action
- (fun _ (ty : 'term) _
- (loc : Lexing.position * Lexing.position) ->
- (ty : 'e__10))]);
- Gramext.Stoken ("", "match"); Gramext.Sself;
- Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "in"); Gramext.Stoken ("IDENT", "")],
- Gramext.action
- (fun (id : string) _
- (loc : Lexing.position * Lexing.position) ->
- (id, None : 'e__11))]);
- Gramext.Stoken ("", "with"); Gramext.Stoken ("SYMBOL", "[");
- Gramext.Slist0sep
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (match_pattern : 'match_pattern Grammar.Entry.e));
- Gramext.Stoken ("SYMBOL", "⇒");
- Gramext.Snterm
- (Grammar.Entry.obj (term : 'term Grammar.Entry.e))],
- Gramext.action
- (fun (rhs : 'term) _ (lhs : 'match_pattern)
- (loc : Lexing.position * Lexing.position) ->
- (lhs, rhs : 'e__12))],
- Gramext.Stoken ("SYMBOL", "|"));
- Gramext.Stoken ("SYMBOL", "]")],
- Gramext.action
- (fun _ (patterns : 'e__12 list) _ _ (indty_ident : 'e__11 option)
- (t : 'term) _ (outtyp : 'e__10 option)
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Case (t, indty_ident, outtyp, patterns)) :
- 'term));
- [Gramext.Snterm (Grammar.Entry.obj (sort : 'sort Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'sort) (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Sort s) : 'term));
- [Gramext.Stoken ("META", "");
- Gramext.Snterm
- (Grammar.Entry.obj (meta_substs : 'meta_substs Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'meta_substs) (m : string)
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Meta (int_of_string m, s)) : 'term));
- [Gramext.Stoken ("META", "")],
- Gramext.action
- (fun (m : string) (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Meta (int_of_string m, [])) : 'term));
- [Gramext.Stoken ("PLACEHOLDER", "")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (return_term loc Ast.UserInput : 'term));
- [Gramext.Stoken ("IMPLICIT", "")],
- Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (return_term loc Ast.Implicit : 'term));
- [Gramext.Stoken ("NUMBER", "")],
- Gramext.action
- (fun (n : string) (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Num (n, 0)) : 'term));
- [Gramext.Stoken ("URI", "")],
- Gramext.action
- (fun (u : string) (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Uri (u, None)) : 'term));
- [Gramext.Stoken ("CSYMBOL", "")],
- Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Symbol (s, 0)) : 'term));
- [Gramext.Stoken ("IDENT", "");
- Gramext.Snterm
- (Grammar.Entry.obj
- (explicit_subst : 'explicit_subst Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'explicit_subst) (id : string)
- (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Ident (id, Some s)) : 'term));
- [Gramext.Stoken ("IDENT", "")],
- Gramext.action
- (fun (id : string) (loc : Lexing.position * Lexing.position) ->
- (return_term loc (Ast.Ident (id, None)) : 'term))]]])
-(* }}} *)
-
-(** {2 API implementation} *)
-
-let exc_located_wrapper f =
- try f () with
- Stdpp.Exc_located (floc, Stream.Error msg) ->
- raise (Parse_error (floc, msg))
- | Stdpp.Exc_located (floc, exn) ->
- raise (Parse_error (floc, Printexc.to_string exn))
-
-let parse_level1_pattern lexbuf =
- CicNotationLexer.set_lexbuf lexbuf;
- exc_located_wrapper
- (fun () -> Grammar.Entry.parse level1_pattern Stream.sempty)
-
-let parse_level2_ast lexbuf =
- CicNotationLexer.set_lexbuf lexbuf;
- exc_located_wrapper (fun () -> Grammar.Entry.parse level2_ast Stream.sempty)
-
-let parse_level2_meta lexbuf =
- CicNotationLexer.set_lexbuf lexbuf;
- exc_located_wrapper
- (fun () -> Grammar.Entry.parse level2_meta Stream.sempty)
-
-let _ =
- parse_level1_pattern_ref := parse_level1_pattern;
- parse_level2_ast_ref := parse_level2_ast;
- parse_level2_meta_ref := parse_level2_meta
-
-(** {2 Debugging} *)
-
-let print_l2_pattern () =
- Grammar.print_entry Format.std_formatter (Grammar.Entry.obj term);
- Format.pp_print_flush Format.std_formatter ();
- flush stdout
-
-(* vim:set encoding=utf8 foldmethod=marker: *)
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Printf
-
-module Ast = CicNotationPt
-module Env = CicNotationEnv
-
-exception Parse_error of string
-exception Level_not_found of int
-
-let level1_pattern_grammar =
- Grammar.gcreate CicNotationLexer.level1_pattern_lexer
-let level2_ast_grammar = Grammar.gcreate CicNotationLexer.level2_ast_lexer
-let level2_meta_grammar = Grammar.gcreate CicNotationLexer.level2_meta_lexer
-
-let min_precedence = 0
-let max_precedence = 100
-
-let level1_pattern =
- Grammar.Entry.create level1_pattern_grammar "level1_pattern"
-let level2_ast = Grammar.Entry.create level2_ast_grammar "level2_ast"
-let term = Grammar.Entry.create level2_ast_grammar "term"
-let let_defs = Grammar.Entry.create level2_ast_grammar "let_defs"
-let level2_meta = Grammar.Entry.create level2_meta_grammar "level2_meta"
-
-let int_of_string s =
- try
- Pervasives.int_of_string s
- with Failure _ ->
- failwith (sprintf "Lexer failure: string_of_int \"%s\" failed" s)
-
-(** {2 Grammar extension} *)
-
-let gram_symbol s = Gramext.Stoken ("SYMBOL", s)
-let gram_ident s = Gramext.Stoken ("IDENT", s)
-let gram_number s = Gramext.Stoken ("NUMBER", s)
-let gram_keyword s = Gramext.Stoken ("", s)
-let gram_term = Gramext.Sself
-
-let gram_of_literal =
- function
- | `Symbol s -> gram_symbol s
- | `Keyword s -> gram_keyword s
- | `Number s -> gram_number s
-
-type binding =
- | NoBinding
- | Binding of string * Env.value_type
- | Env of (string * Env.value_type) list
-
-let make_action action bindings =
- let rec aux (vl : CicNotationEnv.t) =
- function
- [] -> Gramext.action (fun (loc: Ast.location) -> action vl loc)
- | NoBinding :: tl -> Gramext.action (fun _ -> aux vl tl)
- (* LUCA: DEFCON 3 BEGIN *)
- | Binding (name, Env.TermType) :: tl ->
- Gramext.action
- (fun (v:Ast.term) ->
- aux ((name, (Env.TermType, Env.TermValue v))::vl) tl)
- | Binding (name, Env.StringType) :: tl ->
- Gramext.action
- (fun (v:string) ->
- aux ((name, (Env.StringType, Env.StringValue v)) :: vl) tl)
- | Binding (name, Env.NumType) :: tl ->
- Gramext.action
- (fun (v:string) ->
- aux ((name, (Env.NumType, Env.NumValue v)) :: vl) tl)
- | Binding (name, Env.OptType t) :: tl ->
- Gramext.action
- (fun (v:'a option) ->
- aux ((name, (Env.OptType t, Env.OptValue v)) :: vl) tl)
- | Binding (name, Env.ListType t) :: tl ->
- Gramext.action
- (fun (v:'a list) ->
- aux ((name, (Env.ListType t, Env.ListValue v)) :: vl) tl)
- | Env _ :: tl ->
- Gramext.action (fun (v:CicNotationEnv.t) -> aux (v @ vl) tl)
- (* LUCA: DEFCON 3 END *)
- in
- aux [] (List.rev bindings)
-
-let flatten_opt =
- let rec aux acc =
- function
- [] -> List.rev acc
- | NoBinding :: tl -> aux acc tl
- | Env names :: tl -> aux (List.rev names @ acc) tl
- | Binding (name, ty) :: tl -> aux ((name, ty) :: acc) tl
- in
- aux []
-
- (* given a level 1 pattern computes the new RHS of "term" grammar entry *)
-let extract_term_production pattern =
- let rec aux = function
- | Ast.AttributedTerm (_, t) -> aux t
- | Ast.Literal l -> aux_literal l
- | Ast.Layout l -> aux_layout l
- | Ast.Magic m -> aux_magic m
- | Ast.Variable v -> aux_variable v
- | t ->
- prerr_endline (CicNotationPp.pp_term t);
- assert false
- and aux_literal =
- function
- | `Symbol s -> [NoBinding, gram_symbol s]
- | `Keyword s ->
- (* assumption: s will be registered as a keyword with the lexer *)
- [NoBinding, gram_keyword s]
- | `Number s -> [NoBinding, gram_number s]
- and aux_layout = function
- | Ast.Sub (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\sub"] @ aux p2
- | Ast.Sup (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\sup"] @ aux p2
- | Ast.Below (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\below"] @ aux p2
- | Ast.Above (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\above"] @ aux p2
- | Ast.Frac (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\frac"] @ aux p2
- | Ast.Atop (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\atop"] @ aux p2
- | Ast.Over (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\over"] @ aux p2
- | Ast.Root (p1, p2) ->
- [NoBinding, gram_symbol "\\root"] @ aux p2
- @ [NoBinding, gram_symbol "\\of"] @ aux p1
- | Ast.Sqrt p -> [NoBinding, gram_symbol "\\sqrt"] @ aux p
- | Ast.Break -> []
- | Ast.Box (_, pl) -> List.flatten (List.map aux pl)
- | Ast.Group pl -> List.flatten (List.map aux pl)
- and aux_magic magic =
- match magic with
- | Ast.Opt p ->
- let p_bindings, p_atoms, p_names, p_action = inner_pattern p in
- let action (env_opt : CicNotationEnv.t option) (loc : Ast.location) =
- match env_opt with
- | Some env -> List.map Env.opt_binding_some env
- | None -> List.map Env.opt_binding_of_name p_names
- in
- [ Env (List.map Env.opt_declaration p_names),
- Gramext.srules
- [ [ Gramext.Sopt (Gramext.srules [ p_atoms, p_action ]) ],
- Gramext.action action ] ]
- | Ast.List0 (p, _)
- | Ast.List1 (p, _) ->
- let p_bindings, p_atoms, p_names, p_action = inner_pattern p in
-(* let env0 = List.map list_binding_of_name p_names in
- let grow_env_entry env n v =
- List.map
- (function
- | (n', (ty, ListValue vl)) as entry ->
- if n' = n then n', (ty, ListValue (v :: vl)) else entry
- | _ -> assert false)
- env
- in
- let grow_env env_i env =
- List.fold_left
- (fun env (n, (_, v)) -> grow_env_entry env n v)
- env env_i
- in *)
- let action (env_list : CicNotationEnv.t list) (loc : Ast.location) =
- CicNotationEnv.coalesce_env p_names env_list
- in
- let gram_of_list s =
- match magic with
- | Ast.List0 (_, None) -> Gramext.Slist0 s
- | Ast.List1 (_, None) -> Gramext.Slist1 s
- | Ast.List0 (_, Some l) -> Gramext.Slist0sep (s, gram_of_literal l)
- | Ast.List1 (_, Some l) -> Gramext.Slist1sep (s, gram_of_literal l)
- | _ -> assert false
- in
- [ Env (List.map Env.list_declaration p_names),
- Gramext.srules
- [ [ gram_of_list (Gramext.srules [ p_atoms, p_action ]) ],
- Gramext.action action ] ]
- | _ -> assert false
- and aux_variable =
- function
- | Ast.NumVar s -> [Binding (s, Env.NumType), gram_number ""]
- | Ast.TermVar s -> [Binding (s, Env.TermType), gram_term]
- | Ast.IdentVar s -> [Binding (s, Env.StringType), gram_ident ""]
- | Ast.Ascription (p, s) -> assert false (* TODO *)
- | Ast.FreshVar _ -> assert false
- and inner_pattern p =
- let p_bindings, p_atoms = List.split (aux p) in
- let p_names = flatten_opt p_bindings in
- let action =
- make_action (fun (env : CicNotationEnv.t) (loc : Ast.location) -> env)
- p_bindings
- in
- p_bindings, p_atoms, p_names, action
- in
- aux pattern
-
-let level_of precedence associativity =
- if precedence < min_precedence || precedence > max_precedence then
- raise (Level_not_found precedence);
- let assoc_string =
- match associativity with
- | Gramext.NonA -> "N"
- | Gramext.LeftA -> "L"
- | Gramext.RightA -> "R"
- in
- string_of_int precedence ^ assoc_string
-
-type rule_id = Token.t Gramext.g_symbol list
-
- (* mapping: rule_id -> owned keywords. (rule_id, string list) Hashtbl.t *)
-let owned_keywords = Hashtbl.create 23
-
-let extend level1_pattern ~precedence ~associativity action =
- let p_bindings, p_atoms =
- List.split (extract_term_production level1_pattern)
- in
- let level = level_of precedence associativity in
- let p_names = flatten_opt p_bindings in
- let _ =
- Grammar.extend
- [ Grammar.Entry.obj (term: 'a Grammar.Entry.e),
- Some (Gramext.Level level),
- [ None,
- Some associativity,
- [ p_atoms,
- (make_action
- (fun (env: CicNotationEnv.t) (loc: Ast.location) ->
- (action env loc))
- p_bindings) ]]]
- in
- let keywords = CicNotationUtil.keywords_of_term level1_pattern in
- let rule_id = p_atoms in
- List.iter CicNotationLexer.add_level2_ast_keyword keywords;
- Hashtbl.add owned_keywords rule_id keywords; (* keywords may be [] *)
- rule_id
-
-let delete rule_id =
- let atoms = rule_id in
- (try
- let keywords = Hashtbl.find owned_keywords rule_id in
- List.iter CicNotationLexer.remove_level2_ast_keyword keywords
- with Not_found -> assert false);
- Grammar.delete_rule term atoms
-
-(** {2 Grammar} *)
-
-let parse_level1_pattern_ref = ref (fun _ -> assert false)
-let parse_level2_ast_ref = ref (fun _ -> assert false)
-let parse_level2_meta_ref = ref (fun _ -> assert false)
-
-let fold_cluster binder terms ty body =
- List.fold_right
- (fun term body -> Ast.Binder (binder, (term, ty), body))
- terms body (* terms are names: either Ident or FreshVar *)
-
-let fold_exists terms ty body =
- List.fold_right
- (fun term body ->
- let lambda = Ast.Binder (`Lambda, (term, ty), body) in
- Ast.Appl [ Ast.Symbol ("exists", 0); lambda ])
- terms body
-
-let fold_binder binder pt_names body =
- List.fold_right
- (fun (names, ty) body -> fold_cluster binder names ty body)
- pt_names body
-
-let return_term loc term = Ast.AttributedTerm (`Loc loc, term)
-
- (* create empty precedence level for "term" *)
-let _ =
- let dummy_action =
- Gramext.action (fun _ ->
- failwith "internal error, lexer generated a dummy token")
- in
- (* Needed since campl4 on "delete_rule" remove the precedence level if it gets
- * empty after the deletion. The lexer never generate the Stoken below. *)
- let dummy_prod = [ [ Gramext.Stoken ("DUMMY", "") ], dummy_action ] in
- let mk_level_list first last =
- let rec aux acc = function
- | i when i < first -> acc
- | i ->
- aux
- ((Some (string_of_int i ^ "N"), Some Gramext.NonA, dummy_prod)
- :: (Some (string_of_int i ^ "L"), Some Gramext.LeftA, dummy_prod)
- :: (Some (string_of_int i ^ "R"), Some Gramext.RightA, dummy_prod)
- :: acc)
- (i - 1)
- in
- aux [] last
- in
- Grammar.extend
- [ Grammar.Entry.obj (term: 'a Grammar.Entry.e),
- None,
- mk_level_list min_precedence max_precedence ]
-
-(* {{{ Grammar for concrete syntax patterns, notation level 1 *)
-EXTEND
- GLOBAL: level1_pattern;
-
- level1_pattern: [ [ p = l1_pattern; EOI -> CicNotationUtil.boxify p ] ];
- l1_pattern: [ [ p = LIST1 l1_simple_pattern -> p ] ];
- literal: [
- [ s = SYMBOL -> `Symbol s
- | k = QKEYWORD -> `Keyword k
- | n = NUMBER -> `Number n
- ]
- ];
- sep: [ [ "sep"; sep = literal -> sep ] ];
-(* row_sep: [ [ "rowsep"; sep = literal -> sep ] ];
- field_sep: [ [ "fieldsep"; sep = literal -> sep ] ]; *)
- l1_magic_pattern: [
- [ "list0"; p = l1_simple_pattern; sep = OPT sep -> Ast.List0 (p, sep)
- | "list1"; p = l1_simple_pattern; sep = OPT sep -> Ast.List1 (p, sep)
- | "opt"; p = l1_simple_pattern -> Ast.Opt p
- ]
- ];
- l1_pattern_variable: [
- [ "term"; id = IDENT -> Ast.TermVar id
- | "number"; id = IDENT -> Ast.NumVar id
- | "ident"; id = IDENT -> Ast.IdentVar id
- ]
- ];
- l1_simple_pattern:
- [ "layout" LEFTA
- [ p1 = SELF; SYMBOL "\\sub"; p2 = SELF ->
- return_term loc (Ast.Layout (Ast.Sub (p1, p2)))
- | p1 = SELF; SYMBOL "\\sup"; p2 = SELF ->
- return_term loc (Ast.Layout (Ast.Sup (p1, p2)))
- | p1 = SELF; SYMBOL "\\below"; p2 = SELF ->
- return_term loc (Ast.Layout (Ast.Below (p1, p2)))
- | p1 = SELF; SYMBOL "\\above"; p2 = SELF ->
- return_term loc (Ast.Layout (Ast.Above (p1, p2)))
- | p1 = SELF; SYMBOL "\\over"; p2 = SELF ->
- return_term loc (Ast.Layout (Ast.Over (p1, p2)))
- | p1 = SELF; SYMBOL "\\atop"; p2 = SELF ->
- return_term loc (Ast.Layout (Ast.Atop (p1, p2)))
-(* | "array"; p = SELF; csep = OPT field_sep; rsep = OPT row_sep ->
- return_term loc (Array (p, csep, rsep)) *)
- | SYMBOL "\\frac"; p1 = SELF; p2 = SELF ->
- return_term loc (Ast.Layout (Ast.Frac (p1, p2)))
- | SYMBOL "\\sqrt"; p = SELF -> return_term loc (Ast.Layout (Ast.Sqrt p))
- | SYMBOL "\\root"; index = SELF; SYMBOL "\\of"; arg = SELF ->
- return_term loc (Ast.Layout (Ast.Root (arg, index)))
- | "hbox"; LPAREN; p = l1_pattern; RPAREN ->
- return_term loc (Ast.Layout (Ast.Box ((Ast.H, false, false), p)))
- | "vbox"; LPAREN; p = l1_pattern; RPAREN ->
- return_term loc (Ast.Layout (Ast.Box ((Ast.V, false, false), p)))
- | "hvbox"; LPAREN; p = l1_pattern; RPAREN ->
- return_term loc (Ast.Layout (Ast.Box ((Ast.HV, false, false), p)))
- | "hovbox"; LPAREN; p = l1_pattern; RPAREN ->
- return_term loc (Ast.Layout (Ast.Box ((Ast.HOV, false, false), p)))
- | "break" -> return_term loc (Ast.Layout Ast.Break)
-(* | SYMBOL "\\SPACE" -> return_term loc (Layout Space) *)
- | LPAREN; p = l1_pattern; RPAREN ->
- return_term loc (CicNotationUtil.group p)
- ]
- | "simple" NONA
- [ i = IDENT -> return_term loc (Ast.Variable (Ast.TermVar i))
- | m = l1_magic_pattern -> return_term loc (Ast.Magic m)
- | v = l1_pattern_variable -> return_term loc (Ast.Variable v)
- | l = literal -> return_term loc (Ast.Literal l)
- ]
- ];
- END
-(* }}} *)
-
-(* {{{ Grammar for ast magics, notation level 2 *)
-EXTEND
- GLOBAL: level2_meta;
- l2_variable: [
- [ "term"; id = IDENT -> Ast.TermVar id
- | "number"; id = IDENT -> Ast.NumVar id
- | "ident"; id = IDENT -> Ast.IdentVar id
- | "fresh"; id = IDENT -> Ast.FreshVar id
- | "anonymous" -> Ast.TermVar "_"
- | id = IDENT -> Ast.TermVar id
- ]
- ];
- l2_magic: [
- [ "fold"; kind = [ "left" -> `Left | "right" -> `Right ];
- base = level2_meta; "rec"; id = IDENT; recursive = level2_meta ->
- Ast.Fold (kind, base, [id], recursive)
- | "default"; some = level2_meta; none = level2_meta ->
- Ast.Default (some, none)
- | "if"; p_test = level2_meta;
- "then"; p_true = level2_meta;
- "else"; p_false = level2_meta ->
- Ast.If (p_test, p_true, p_false)
- | "fail" -> Ast.Fail
- ]
- ];
- level2_meta: [
- [ magic = l2_magic -> Ast.Magic magic
- | var = l2_variable -> Ast.Variable var
- | blob = UNPARSED_AST ->
- !parse_level2_ast_ref (Ulexing.from_utf8_string blob)
- ]
- ];
-END
-(* }}} *)
-
-(* {{{ Grammar for ast patterns, notation level 2 *)
-EXTEND
- GLOBAL: level2_ast term let_defs;
- level2_ast: [ [ p = term -> p ] ];
- sort: [
- [ "Prop" -> `Prop
- | "Set" -> `Set
- | "Type" -> `Type (CicUniv.fresh ())
- | "CProp" -> `CProp
- ]
- ];
- explicit_subst: [
- [ SYMBOL "\\subst"; (* to avoid catching frequent "a [1]" cases *)
- SYMBOL "[";
- substs = LIST1 [
- i = IDENT; SYMBOL <:unicode<Assign>> (* ≔ *); t = term -> (i, t)
- ] SEP SYMBOL ";";
- SYMBOL "]" ->
- substs
- ]
- ];
- meta_subst: [
- [ s = SYMBOL "_" -> None
- | p = term -> Some p ]
- ];
- meta_substs: [
- [ SYMBOL "["; substs = LIST0 meta_subst; SYMBOL "]" -> substs ]
- ];
- possibly_typed_name: [
- [ LPAREN; id = single_arg; SYMBOL ":"; typ = term; RPAREN ->
- id, Some typ
- | arg = single_arg -> arg, None
- ]
- ];
- match_pattern: [
- [ id = IDENT -> id, None, []
- | LPAREN; id = IDENT; vars = LIST1 possibly_typed_name; RPAREN ->
- id, None, vars
- ]
- ];
- binder: [
- [ SYMBOL <:unicode<Pi>> (* Π *) -> `Pi
-(* | SYMBOL <:unicode<exists>> |+ ∃ +| -> `Exists *)
- | SYMBOL <:unicode<forall>> (* ∀ *) -> `Forall
- | SYMBOL <:unicode<lambda>> (* λ *) -> `Lambda
- ]
- ];
- arg: [
- [ LPAREN; names = LIST1 IDENT SEP SYMBOL ",";
- SYMBOL ":"; ty = term; RPAREN ->
- List.map (fun n -> Ast.Ident (n, None)) names, Some ty
- | name = IDENT -> [Ast.Ident (name, None)], None
- | blob = UNPARSED_META ->
- let meta = !parse_level2_meta_ref (Ulexing.from_utf8_string blob) in
- match meta with
- | Ast.Variable (Ast.FreshVar _) -> [meta], None
- | Ast.Variable (Ast.TermVar "_") -> [Ast.Ident ("_", None)], None
- | _ -> failwith "Invalid bound name."
- ]
- ];
- single_arg: [
- [ name = IDENT -> Ast.Ident (name, None)
- | blob = UNPARSED_META ->
- let meta = !parse_level2_meta_ref (Ulexing.from_utf8_string blob) in
- match meta with
- | Ast.Variable (Ast.FreshVar _)
- | Ast.Variable (Ast.IdentVar _) -> meta
- | Ast.Variable (Ast.TermVar "_") -> Ast.Ident ("_", None)
- | _ -> failwith "Invalid index name."
- ]
- ];
- induction_kind: [
- [ "rec" -> `Inductive
- | "corec" -> `CoInductive
- ]
- ];
- let_defs: [
- [ defs = LIST1 [
- name = single_arg;
- args = LIST1 arg;
- index_name = OPT [ "on"; id = single_arg -> id ];
- ty = OPT [ SYMBOL ":" ; p = term -> p ];
- SYMBOL <:unicode<def>> (* ≝ *); body = term ->
- let body = fold_binder `Lambda args body in
- let ty =
- match ty with
- | None -> None
- | Some ty -> Some (fold_binder `Pi args ty)
- in
- let rec position_of name p = function
- | [] -> None, p
- | n :: _ when n = name -> Some p, p
- | _ :: tl -> position_of name (p + 1) tl
- in
- let rec find_arg name n = function
- | [] ->
- Ast.fail loc (sprintf "Argument %s not found"
- (CicNotationPp.pp_term name))
- | (l,_) :: tl ->
- (match position_of name 0 l with
- | None, len -> find_arg name (n + len) tl
- | Some where, len -> n + where)
- in
- let index =
- match index_name with
- | None -> 0
- | Some index_name -> find_arg index_name 0 args
- in
- (name, ty), body, index
- ] SEP "and" ->
- defs
- ]
- ];
- binder_vars: [
- [ vars = [
- l = LIST1 single_arg SEP SYMBOL "," -> l
- | SYMBOL "_" -> [Ast.Ident ("_", None)] ];
- typ = OPT [ SYMBOL ":"; t = term -> t ] -> (vars, typ)
- | LPAREN;
- vars = [
- l = LIST1 single_arg SEP SYMBOL "," -> l
- | SYMBOL "_" -> [Ast.Ident ("_", None)] ];
- typ = OPT [ SYMBOL ":"; t = term -> t ];
- RPAREN -> (vars, typ)
- ]
- ];
- term: LEVEL "10N" [ (* let in *)
- [ "let"; var = possibly_typed_name; SYMBOL <:unicode<def>> (* ≝ *);
- p1 = term; "in"; p2 = term ->
- return_term loc (Ast.LetIn (var, p1, p2))
- | "let"; k = induction_kind; defs = let_defs; "in";
- body = term ->
- return_term loc (Ast.LetRec (k, defs, body))
- ]
- ];
- term: LEVEL "20R" (* binder *)
- [
- [ b = binder; (vars, typ) = binder_vars; SYMBOL "."; body = term ->
- return_term loc (fold_cluster b vars typ body)
- | SYMBOL <:unicode<exists>> (* ∃ *);
- (vars, typ) = binder_vars; SYMBOL "."; body = term ->
- return_term loc (fold_exists vars typ body)
- ]
- ];
- term: LEVEL "70L" (* apply *)
- [
- [ p1 = term; p2 = term ->
- let rec aux = function
- | Ast.Appl (hd :: tl)
- | Ast.AttributedTerm (_, Ast.Appl (hd :: tl)) ->
- aux hd @ tl
- | term -> [term]
- in
- return_term loc (Ast.Appl (aux p1 @ [p2]))
- ]
- ];
- term: LEVEL "90N" (* simple *)
- [
- [ id = IDENT -> return_term loc (Ast.Ident (id, None))
- | id = IDENT; s = explicit_subst ->
- return_term loc (Ast.Ident (id, Some s))
- | s = CSYMBOL -> return_term loc (Ast.Symbol (s, 0))
- | u = URI -> return_term loc (Ast.Uri (u, None))
- | n = NUMBER -> return_term loc (Ast.Num (n, 0))
- | IMPLICIT -> return_term loc (Ast.Implicit)
- | PLACEHOLDER -> return_term loc Ast.UserInput
- | m = META -> return_term loc (Ast.Meta (int_of_string m, []))
- | m = META; s = meta_substs ->
- return_term loc (Ast.Meta (int_of_string m, s))
- | s = sort -> return_term loc (Ast.Sort s)
- | "match"; t = term;
- indty_ident = OPT [ "in"; id = IDENT -> id, None ];
- outtyp = OPT [ "return"; ty = term -> ty ];
- "with"; SYMBOL "[";
- patterns = LIST0 [
- lhs = match_pattern; SYMBOL <:unicode<Rightarrow>> (* ⇒ *);
- rhs = term ->
- lhs, rhs
- ] SEP SYMBOL "|";
- SYMBOL "]" ->
- return_term loc (Ast.Case (t, indty_ident, outtyp, patterns))
- | LPAREN; p1 = term; SYMBOL ":"; p2 = term; RPAREN ->
- return_term loc (Ast.Cast (p1, p2))
- | LPAREN; p = term; RPAREN -> p
- | blob = UNPARSED_META ->
- !parse_level2_meta_ref (Ulexing.from_utf8_string blob)
- ]
- ];
-END
-(* }}} *)
-
-(** {2 API implementation} *)
-
-let exc_located_wrapper f =
- try
- f ()
- with
- | Stdpp.Exc_located (floc, Stream.Error msg) ->
- raise (HExtlib.Localized (floc, Parse_error msg))
- | Stdpp.Exc_located (floc, exn) ->
- raise (HExtlib.Localized (floc, (Parse_error (Printexc.to_string exn))))
-
-let parse_level1_pattern lexbuf =
- exc_located_wrapper
- (fun () -> Grammar.Entry.parse level1_pattern (Obj.magic lexbuf))
-
-let parse_level2_ast lexbuf =
- exc_located_wrapper
- (fun () -> Grammar.Entry.parse level2_ast (Obj.magic lexbuf))
-
-let parse_level2_meta lexbuf =
- exc_located_wrapper
- (fun () -> Grammar.Entry.parse level2_meta (Obj.magic lexbuf))
-
-let _ =
- parse_level1_pattern_ref := parse_level1_pattern;
- parse_level2_ast_ref := parse_level2_ast;
- parse_level2_meta_ref := parse_level2_meta
-
-(** {2 Debugging} *)
-
-let print_l2_pattern () =
- Grammar.print_entry Format.std_formatter (Grammar.Entry.obj term);
- Format.pp_print_flush Format.std_formatter ();
- flush stdout
-
-(* vim:set encoding=utf8 foldmethod=marker: *)
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-exception Parse_error of string
-exception Level_not_found of int
-
-(** {2 Parsing functions} *)
-
- (** concrete syntax pattern: notation level 1 *)
-val parse_level1_pattern: Ulexing.lexbuf -> CicNotationPt.term
-
- (** AST pattern: notation level 2 *)
-val parse_level2_ast: Ulexing.lexbuf -> CicNotationPt.term
-val parse_level2_meta: Ulexing.lexbuf -> CicNotationPt.term
-
-(** {2 Grammar extension} *)
-
-type rule_id
-
-val extend:
- CicNotationPt.term -> (* level 1 pattern *)
- precedence:int ->
- associativity:Gramext.g_assoc ->
- (CicNotationEnv.t -> CicNotationPt.location -> CicNotationPt.term) ->
- rule_id
-
-val delete: rule_id -> unit
-
-(** {2 Grammar entries}
- * needed by grafite parser *)
-
-val level2_ast_grammar: Grammar.g
-
-val term : CicNotationPt.term Grammar.Entry.e
-
-val let_defs :
- (CicNotationPt.capture_variable * CicNotationPt.term * int) list
- Grammar.Entry.e
-
-(** {2 Debugging} *)
-
- (** print "level2_pattern" entry on stdout, flushing afterwards *)
-val print_l2_pattern: unit -> unit
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Printf
-
-module Ast = CicNotationPt
-module Env = CicNotationEnv
-
- (* when set to true debugging information, not in sync with input syntax, will
- * be added to the output of pp_term.
- * set to false if you need, for example, cut and paste from matitac output to
- * matitatop *)
-let debug_printing = true
-
-let pp_binder = function
- | `Lambda -> "lambda"
- | `Pi -> "Pi"
- | `Exists -> "exists"
- | `Forall -> "forall"
-
-let pp_literal =
- if debug_printing then
- (function (* debugging version *)
- | `Symbol s -> sprintf "symbol(%s)" s
- | `Keyword s -> sprintf "keyword(%s)" s
- | `Number s -> sprintf "number(%s)" s)
- else
- (function
- | `Symbol s
- | `Keyword s
- | `Number s -> s)
-
-let pp_assoc =
- function
- | Gramext.NonA -> "NonA"
- | Gramext.LeftA -> "LeftA"
- | Gramext.RightA -> "RightA"
-
-let pp_pos =
- function
-(* `None -> "`None" *)
- | `Left -> "`Left"
- | `Right -> "`Right"
- | `Inner -> "`Inner"
-
-let pp_attribute =
- function
- | `IdRef id -> sprintf "x(%s)" id
- | `XmlAttrs attrs ->
- sprintf "X(%s)"
- (String.concat ";"
- (List.map (fun (_, n, v) -> sprintf "%s=%s" n v) attrs))
- | `Level (prec, assoc) -> sprintf "L(%d%s)" prec (pp_assoc assoc)
- | `Raw _ -> "R"
- | `Loc _ -> "@"
- | `ChildPos p -> sprintf "P(%s)" (pp_pos p)
-
-let rec pp_term ?(pp_parens = true) t =
- let t_pp =
- match t with
- | Ast.AttributedTerm (attr, term) when debug_printing ->
- sprintf "%s[%s]" (pp_attribute attr) (pp_term ~pp_parens:false term)
- | Ast.AttributedTerm (`Raw text, _) -> text
- | Ast.AttributedTerm (_, term) -> pp_term ~pp_parens:false term
- | Ast.Appl terms ->
- sprintf "%s" (String.concat " " (List.map pp_term terms))
- | Ast.Binder (`Forall, (Ast.Ident ("_", None), typ), body)
- | Ast.Binder (`Pi, (Ast.Ident ("_", None), typ), body) ->
- sprintf "%s \\to %s"
- (match typ with None -> "?" | Some typ -> pp_term typ)
- (pp_term body)
- | Ast.Binder (kind, var, body) ->
- sprintf "\\%s %s.%s" (pp_binder kind) (pp_capture_variable var)
- (pp_term body)
- | Ast.Case (term, indtype, typ, patterns) ->
- sprintf "%smatch %s%s with %s"
- (match typ with None -> "" | Some t -> sprintf "[%s]" (pp_term t))
- (pp_term term)
- (match indtype with
- | None -> ""
- | Some (ty, href_opt) ->
- sprintf " in %s%s" ty
- (match debug_printing, href_opt with
- | true, Some uri ->
- sprintf "(i.e.%s)" (UriManager.string_of_uri uri)
- | _ -> ""))
- (pp_patterns patterns)
- | Ast.Cast (t1, t2) -> sprintf "(%s: %s)" (pp_term t1) (pp_term t2)
- | Ast.LetIn (var, t1, t2) ->
- sprintf "let %s = %s in %s" (pp_capture_variable var) (pp_term t1)
- (pp_term t2)
- | Ast.LetRec (kind, definitions, term) ->
- sprintf "let %s %s in %s"
- (match kind with `Inductive -> "rec" | `CoInductive -> "corec")
- (String.concat " and "
- (List.map
- (fun (var, body, _) ->
- sprintf "%s = %s" (pp_capture_variable var) (pp_term body))
- definitions))
- (pp_term term)
- | Ast.Ident (name, Some []) | Ast.Ident (name, None)
- | Ast.Uri (name, Some []) | Ast.Uri (name, None) ->
- name
- | Ast.Ident (name, Some substs)
- | Ast.Uri (name, Some substs) ->
- sprintf "%s \\subst [%s]" name (pp_substs substs)
- | Ast.Implicit -> "?"
- | Ast.Meta (index, substs) ->
- sprintf "%d[%s]" index
- (String.concat "; "
- (List.map (function None -> "_" | Some t -> pp_term t) substs))
- | Ast.Num (num, _) -> num
- | Ast.Sort `Set -> "Set"
- | Ast.Sort `Prop -> "Prop"
- | Ast.Sort (`Type _) -> "Type"
- | Ast.Sort `CProp -> "CProp"
- | Ast.Symbol (name, _) -> "'" ^ name
-
- | Ast.UserInput -> ""
-
- | Ast.Literal l -> pp_literal l
- | Ast.Layout l -> pp_layout l
- | Ast.Magic m -> pp_magic m
- | Ast.Variable v -> pp_variable v
- in
- if pp_parens then sprintf "(%s)" t_pp
- else t_pp
-
-and pp_subst (name, term) = sprintf "%s \\Assign %s" name (pp_term term)
-and pp_substs substs = String.concat "; " (List.map pp_subst substs)
-
-and pp_pattern ((head, href, vars), term) =
- let head_pp =
- head ^
- (match debug_printing, href with
- | true, Some uri -> sprintf "(i.e.%s)" (UriManager.string_of_uri uri)
- | _ -> "")
- in
- sprintf "%s \\Rightarrow %s"
- (match vars with
- | [] -> head_pp
- | _ ->
- sprintf "(%s %s)" head_pp
- (String.concat " " (List.map pp_capture_variable vars)))
- (pp_term term)
-
-and pp_patterns patterns =
- sprintf "[%s]" (String.concat " | " (List.map pp_pattern patterns))
-
-and pp_capture_variable = function
- | term, None -> pp_term term
- | term, Some typ -> "(" ^ pp_term term ^ ": " ^ pp_term typ ^ ")"
-
-and pp_box_spec (kind, spacing, indent) =
- let int_of_bool b = if b then 1 else 0 in
- let kind_string =
- match kind with
- Ast.H -> "H" | Ast.V -> "V" | Ast.HV -> "HV" | Ast.HOV -> "HOV"
- in
- sprintf "%sBOX%d%d" kind_string (int_of_bool spacing) (int_of_bool indent)
-
-and pp_layout = function
- | Ast.Sub (t1, t2) -> sprintf "%s \\SUB %s" (pp_term t1) (pp_term t2)
- | Ast.Sup (t1, t2) -> sprintf "%s \\SUP %s" (pp_term t1) (pp_term t2)
- | Ast.Below (t1, t2) -> sprintf "%s \\BELOW %s" (pp_term t1) (pp_term t2)
- | Ast.Above (t1, t2) -> sprintf "%s \\ABOVE %s" (pp_term t1) (pp_term t2)
- | Ast.Over (t1, t2) -> sprintf "[%s \\OVER %s]" (pp_term t1) (pp_term t2)
- | Ast.Atop (t1, t2) -> sprintf "[%s \\ATOP %s]" (pp_term t1) (pp_term t2)
- | Ast.Frac (t1, t2) -> sprintf "\\FRAC %s %s" (pp_term t1) (pp_term t2)
- | Ast.Sqrt t -> sprintf "\\SQRT %s" (pp_term t)
- | Ast.Root (arg, index) ->
- sprintf "\\ROOT %s \\OF %s" (pp_term index) (pp_term arg)
- | Ast.Break -> "\\BREAK"
-(* | Space -> "\\SPACE" *)
- | Ast.Box (box_spec, terms) ->
- sprintf "\\%s [%s]" (pp_box_spec box_spec)
- (String.concat " " (List.map pp_term terms))
- | Ast.Group terms ->
- sprintf "\\GROUP [%s]" (String.concat " " (List.map pp_term terms))
-
-and pp_magic = function
- | Ast.List0 (t, sep_opt) ->
- sprintf "list0 %s%s" (pp_term t) (pp_sep_opt sep_opt)
- | Ast.List1 (t, sep_opt) ->
- sprintf "list1 %s%s" (pp_term t) (pp_sep_opt sep_opt)
- | Ast.Opt t -> sprintf "opt %s" (pp_term t)
- | Ast.Fold (kind, p_base, names, p_rec) ->
- let acc = match names with acc :: _ -> acc | _ -> assert false in
- sprintf "fold %s %s rec %s %s"
- (pp_fold_kind kind) (pp_term p_base) acc (pp_term p_rec)
- | Ast.Default (p_some, p_none) ->
- sprintf "default %s %s" (pp_term p_some) (pp_term p_none)
- | Ast.If (p_test, p_true, p_false) ->
- sprintf "if %s then %s else %s"
- (pp_term p_test) (pp_term p_true) (pp_term p_false)
- | Ast.Fail -> "fail"
-
-and pp_fold_kind = function
- | `Left -> "left"
- | `Right -> "right"
-
-and pp_sep_opt = function
- | None -> ""
- | Some sep -> sprintf " sep %s" (pp_literal sep)
-
-and pp_variable = function
- | Ast.NumVar s -> "number " ^ s
- | Ast.IdentVar s -> "ident " ^ s
- | Ast.TermVar s -> "term " ^ s
- | Ast.Ascription (t, n) -> assert false
- | Ast.FreshVar n -> "fresh " ^ n
-
-let pp_term t = pp_term ~pp_parens:false t
-
-let rec pp_value = function
- | Env.TermValue t -> sprintf "$%s$" (pp_term t)
- | Env.StringValue s -> sprintf "\"%s\"" s
- | Env.NumValue n -> n
- | Env.OptValue (Some v) -> "Some " ^ pp_value v
- | Env.OptValue None -> "None"
- | Env.ListValue l -> sprintf "[%s]" (String.concat "; " (List.map pp_value l))
-
-let rec pp_value_type =
- function
- | Env.TermType -> "Term"
- | Env.StringType -> "String"
- | Env.NumType -> "Number"
- | Env.OptType t -> "Maybe " ^ pp_value_type t
- | Env.ListType l -> "List " ^ pp_value_type l
-
-let pp_env env =
- String.concat "; "
- (List.map
- (fun (name, (ty, value)) ->
- sprintf "%s : %s = %s" name (pp_value_type ty) (pp_value value))
- env)
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-val pp_term: CicNotationPt.term -> string
-
-val pp_env: CicNotationEnv.t -> string
-val pp_value: CicNotationEnv.value -> string
-val pp_value_type: CicNotationEnv.value_type -> string
-
-val pp_pos: CicNotationPt.child_pos -> string
-val pp_attribute: CicNotationPt.term_attribute -> string
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-module Ast = CicNotationPt
-module Mpres = Mpresentation
-
-type mathml_markup = boxml_markup Mpres.mpres
-and boxml_markup = mathml_markup Box.box
-
-type markup = mathml_markup
-
-let atop_attributes = [None, "linethickness", "0pt"]
-
-let to_unicode = Utf8Macro.unicode_of_tex
-
-let rec make_attributes l1 = function
- | [] -> []
- | hd :: tl ->
- (match hd with
- | None -> make_attributes (List.tl l1) tl
- | Some s ->
- let p,n = List.hd l1 in
- (p,n,s) :: make_attributes (List.tl l1) tl)
-
-let box_of_mpres =
- function
- | Mpresentation.Mobject (attrs, box) ->
- assert (attrs = []);
- box
- | mpres -> Box.Object ([], mpres)
-
-let mpres_of_box =
- function
- | Box.Object (attrs, mpres) ->
- assert (attrs = []);
- mpres
- | box -> Mpresentation.Mobject ([], box)
-
-let rec genuine_math =
- function
- | Mpresentation.Mobject ([], obj) -> not (genuine_box obj)
- | _ -> true
-and genuine_box =
- function
- | Box.Object ([], mpres) -> not (genuine_math mpres)
- | _ -> true
-
-let rec eligible_math =
- function
- | Mpresentation.Mobject ([], Box.Object ([], mpres)) -> eligible_math mpres
- | Mpresentation.Mobject ([], _) -> false
- | _ -> true
-
-let rec promote_to_math =
- function
- | Mpresentation.Mobject ([], Box.Object ([], mpres)) -> promote_to_math mpres
- | math -> math
-
-let small_skip =
- Mpresentation.Mspace (RenderingAttrs.small_skip_attributes `MathML)
-
-let rec add_mpres_attributes new_attr = function
- | Mpresentation.Mobject (attr, box) ->
- Mpresentation.Mobject (attr, add_box_attributes new_attr box)
- | mpres ->
- Mpresentation.set_attr (new_attr @ Mpresentation.get_attr mpres) mpres
-and add_box_attributes new_attr = function
- | Box.Object (attr, mpres) ->
- Box.Object (attr, add_mpres_attributes new_attr mpres)
- | box -> Box.set_attr (new_attr @ Box.get_attr box) box
-
-let box_of mathonly spec attrs children =
- match children with
- | [t] -> add_mpres_attributes attrs t
- | _ ->
- let kind, spacing, indent = spec in
- let dress children =
- if spacing then
- CicNotationUtil.dress small_skip children
- else
- children
- in
- if mathonly then Mpresentation.Mrow (attrs, dress children)
- else
- let attrs' =
- (if spacing then RenderingAttrs.spacing_attributes `BoxML else [])
- @ (if indent then RenderingAttrs.indent_attributes `BoxML else [])
- @ attrs
- in
- match kind with
- | Ast.H ->
- if List.for_all eligible_math children then
- Mpresentation.Mrow (attrs',
- dress (List.map promote_to_math children))
- else
- mpres_of_box (Box.H (attrs',
- List.map box_of_mpres children))
-(* | Ast.H when List.for_all genuine_math children ->
- Mpresentation.Mrow (attrs', dress children) *)
- | Ast.V ->
- mpres_of_box (Box.V (attrs',
- List.map box_of_mpres children))
- | Ast.HV ->
- mpres_of_box (Box.HV (attrs',
- List.map box_of_mpres children))
- | Ast.HOV ->
- mpres_of_box (Box.HOV (attrs',
- List.map box_of_mpres children))
-
-let open_paren = Mpresentation.Mo ([], "(")
-let closed_paren = Mpresentation.Mo ([], ")")
-let open_brace = Mpresentation.Mo ([], "{")
-let closed_brace = Mpresentation.Mo ([], "}")
-let hidden_substs = Mpresentation.Mtext ([], "{...}")
-let open_box_paren = Box.Text ([], "(")
-let closed_box_paren = Box.Text ([], ")")
-let semicolon = Mpresentation.Mo ([], ";")
-let toggle_action children =
- Mpresentation.Maction ([None, "actiontype", "toggle"], children)
-
-type child_pos = [ `Left | `Right | `Inner ]
-
-let pp_assoc =
- function
- | Gramext.LeftA -> "LeftA"
- | Gramext.RightA -> "RightA"
- | Gramext.NonA -> "NonA"
-
-let is_atomic t =
- let rec aux_mpres = function
- | Mpres.Mi _
- | Mpres.Mo _
- | Mpres.Mn _
- | Mpres.Ms _
- | Mpres.Mtext _
- | Mpres.Mspace _ -> true
- | Mpres.Mobject (_, box) -> aux_box box
- | Mpres.Maction (_, [mpres])
- | Mpres.Mrow (_, [mpres]) -> aux_mpres mpres
- | _ -> false
- and aux_box = function
- | Box.Space _
- | Box.Ink _
- | Box.Text _ -> true
- | Box.Object (_, mpres) -> aux_mpres mpres
- | Box.H (_, [box])
- | Box.V (_, [box])
- | Box.HV (_, [box])
- | Box.HOV (_, [box])
- | Box.Action (_, [box]) -> aux_box box
- | _ -> false
- in
- aux_mpres t
-
-let add_parens child_prec child_assoc child_pos curr_prec t =
- if is_atomic t then t
- else if child_prec >= 0
- && (child_prec < curr_prec
- || (child_prec = curr_prec &&
- child_assoc = Gramext.LeftA &&
- child_pos = `Right)
- || (child_prec = curr_prec &&
- child_assoc = Gramext.RightA &&
- child_pos = `Left))
- then (* parens should be added *)
-(* (prerr_endline "adding parens";
- prerr_endline (Printf.sprintf "child_prec = %d\nchild_assoc = %s\nchild_pos = %s\ncurr_prec= %d"
- child_prec (pp_assoc child_assoc) (CicNotationPp.pp_pos
- child_pos) curr_prec); *)
- match t with
- | Mpresentation.Mobject (_, box) ->
- mpres_of_box (Box.H ([], [ open_box_paren; box; closed_box_paren ]))
- | mpres -> Mpresentation.Mrow ([], [open_paren; t; closed_paren])
- else
- t
-
-let render ids_to_uris =
- let module A = Ast in
- let module P = Mpresentation in
- let use_unicode = true in
- let lookup_uri id =
- (try
- let uri = Hashtbl.find ids_to_uris id in
- Some (UriManager.string_of_uri uri)
- with Not_found -> None)
- in
- let make_href xmlattrs xref =
- let xref_uris =
- List.fold_right
- (fun xref uris ->
- match lookup_uri xref with
- | None -> uris
- | Some uri -> uri :: uris)
- !xref []
- in
- let xmlattrs_uris, xmlattrs =
- let xref_attrs, other_attrs =
- List.partition
- (function Some "xlink", "href", _ -> true | _ -> false)
- xmlattrs
- in
- List.map (fun (_, _, uri) -> uri) xref_attrs,
- other_attrs
- in
- let uris =
- match xmlattrs_uris @ xref_uris with
- | [] -> None
- | uris ->
- Some (String.concat " "
- (HExtlib.list_uniq (List.sort String.compare uris)))
- in
- let xrefs =
- match !xref with [] -> None | xrefs -> Some (String.concat " " xrefs)
- in
- xref := [];
- xmlattrs
- @ make_attributes [Some "helm", "xref"; Some "xlink", "href"]
- [xrefs; uris]
- in
- let make_xref xref =
- let xrefs =
- match !xref with [] -> None | xrefs -> Some (String.concat " " xrefs)
- in
- xref := [];
- make_attributes [Some "helm","xref"] [xrefs]
- in
- (* when mathonly is true no boxes should be generated, only mrows *)
- (* "xref" is *)
- let rec aux xmlattrs mathonly xref pos prec t =
- match t with
- | A.AttributedTerm _ ->
- aux_attributes xmlattrs mathonly xref pos prec t
- | A.Num (literal, _) ->
- let attrs =
- (RenderingAttrs.number_attributes `MathML)
- @ make_href xmlattrs xref
- in
- Mpres.Mn (attrs, literal)
- | A.Symbol (literal, _) ->
- let attrs =
- (RenderingAttrs.symbol_attributes `MathML)
- @ make_href xmlattrs xref
- in
- Mpres.Mo (attrs, to_unicode literal)
- | A.Ident (literal, subst)
- | A.Uri (literal, subst) ->
- let attrs =
- (RenderingAttrs.ident_attributes `MathML)
- @ make_href xmlattrs xref
- in
- let name = Mpres.Mi (attrs, to_unicode literal) in
- (match subst with
- | Some []
- | None -> name
- | Some substs ->
- let substs' =
- box_of mathonly (A.H, false, false) []
- (open_brace
- :: (CicNotationUtil.dress semicolon
- (List.map
- (fun (name, t) ->
- box_of mathonly (A.H, false, false) [] [
- Mpres.Mi ([], name);
- Mpres.Mo ([], to_unicode "\\def");
- aux [] mathonly xref pos prec t ])
- substs))
- @ [ closed_brace ])
- in
- let substs_maction = toggle_action [ hidden_substs; substs' ] in
- box_of mathonly (A.H, false, false) [] [ name; substs_maction ])
- | A.Literal l -> aux_literal xmlattrs xref prec l
- | A.UserInput -> Mpres.Mtext ([], "%")
- | A.Layout l -> aux_layout mathonly xref pos prec l
- | A.Magic _
- | A.Variable _ -> assert false (* should have been instantiated *)
- | t ->
- prerr_endline ("unexpected ast: " ^ CicNotationPp.pp_term t);
- assert false
- and aux_attributes xmlattrs mathonly xref pos prec t =
- let reset = ref false in
- let new_level = ref None in
- let new_xref = ref [] in
- let new_xmlattrs = ref [] in
- let new_pos = ref pos in
- let reinit = ref false in
- let rec aux_attribute =
- function
- | A.AttributedTerm (attr, t) ->
- (match attr with
- | `Loc _
- | `Raw _ -> ()
- | `Level (-1, _) -> reset := true
- | `Level (child_prec, child_assoc) ->
- new_level := Some (child_prec, child_assoc)
- | `IdRef xref -> new_xref := xref :: !new_xref
- | `ChildPos pos -> new_pos := pos
- | `XmlAttrs attrs -> new_xmlattrs := attrs @ !new_xmlattrs);
- aux_attribute t
- | t ->
- (match !new_level with
- | None -> aux !new_xmlattrs mathonly new_xref !new_pos prec t
- | Some (child_prec, child_assoc) ->
- let t' =
- aux !new_xmlattrs mathonly new_xref !new_pos child_prec t
- in
- if !reset then t'
- else add_parens child_prec child_assoc !new_pos prec t')
- in
- aux_attribute t
- and aux_literal xmlattrs xref prec l =
- let attrs = make_href xmlattrs xref in
- (match l with
- | `Symbol s -> Mpres.Mo (attrs, to_unicode s)
- | `Keyword s -> Mpres.Mo (attrs, to_unicode s)
- | `Number s -> Mpres.Mn (attrs, to_unicode s))
- and aux_layout mathonly xref pos prec l =
- let attrs = make_xref xref in
- let invoke' t = aux [] true (ref []) pos prec t in
- (* use the one below to reset precedence and associativity *)
- let invoke_reinit t = aux [] mathonly xref `Inner ~-1 t in
- match l with
- | A.Sub (t1, t2) -> Mpres.Msub (attrs, invoke' t1, invoke_reinit t2)
- | A.Sup (t1, t2) -> Mpres.Msup (attrs, invoke' t1, invoke_reinit t2)
- | A.Below (t1, t2) -> Mpres.Munder (attrs, invoke' t1, invoke_reinit t2)
- | A.Above (t1, t2) -> Mpres.Mover (attrs, invoke' t1, invoke_reinit t2)
- | A.Frac (t1, t2)
- | A.Over (t1, t2) ->
- Mpres.Mfrac (attrs, invoke_reinit t1, invoke_reinit t2)
- | A.Atop (t1, t2) ->
- Mpres.Mfrac (atop_attributes @ attrs, invoke_reinit t1,
- invoke_reinit t2)
- | A.Sqrt t -> Mpres.Msqrt (attrs, invoke_reinit t)
- | A.Root (t1, t2) ->
- Mpres.Mroot (attrs, invoke_reinit t1, invoke_reinit t2)
- | A.Box ((_, spacing, _) as kind, terms) ->
- let children =
- aux_children mathonly spacing xref pos prec
- (CicNotationUtil.ungroup terms)
- in
- box_of mathonly kind attrs children
- | A.Group terms ->
- let children =
- aux_children mathonly false xref pos prec
- (CicNotationUtil.ungroup terms)
- in
- box_of mathonly (A.H, false, false) attrs children
- | A.Break -> assert false (* TODO? *)
- and aux_children mathonly spacing xref pos prec terms =
- let find_clusters =
- let rec aux_list first clusters acc =
- function
- [] when acc = [] -> List.rev clusters
- | [] -> aux_list first (List.rev acc :: clusters) [] []
- | (A.Layout A.Break) :: tl when acc = [] ->
- aux_list first clusters [] tl
- | (A.Layout A.Break) :: tl ->
- aux_list first (List.rev acc :: clusters) [] tl
- | [hd] ->
-(* let pos' =
- if first then
- pos
- else
- match pos with
- `None -> `Right
- | `Inner -> `Inner
- | `Right -> `Right
- | `Left -> `Inner
- in *)
- aux_list false clusters
- (aux [] mathonly xref pos prec hd :: acc) []
- | hd :: tl ->
-(* let pos' =
- match pos, first with
- `None, true -> `Left
- | `None, false -> `Inner
- | `Left, true -> `Left
- | `Left, false -> `Inner
- | `Right, _ -> `Inner
- | `Inner, _ -> `Inner
- in *)
- aux_list false clusters
- (aux [] mathonly xref pos prec hd :: acc) tl
- in
- aux_list true [] []
- in
- let boxify_pres =
- function
- [t] -> t
- | tl -> box_of mathonly (A.H, spacing, false) [] tl
- in
- List.map boxify_pres (find_clusters terms)
- in
- aux [] false (ref []) `Inner ~-1
-
-let rec print_box (t: boxml_markup) =
- Box.box2xml print_mpres t
-and print_mpres (t: mathml_markup) =
- Mpresentation.print_mpres print_box t
-
-let print_xml = print_mpres
-
-(* let render_to_boxml id_to_uri t =
- let xml_stream = print_box (box_of_mpres (render id_to_uri t)) in
- Xml.add_xml_declaration xml_stream *)
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-type mathml_markup = boxml_markup Mpresentation.mpres
-and boxml_markup = mathml_markup Box.box
-
-type markup = mathml_markup
-
-(** {2 Markup conversions} *)
-
-val mpres_of_box: boxml_markup -> mathml_markup
-val box_of_mpres: mathml_markup -> boxml_markup
-
-(** {2 Rendering} *)
-
-(** level 1 -> level 0
- * @param ids_to_uris mapping id -> uri for hyperlinking *)
-val render: (Cic.id, UriManager.uri) Hashtbl.t -> CicNotationPt.term -> markup
-
-(** level 0 -> xml stream *)
-val print_xml: markup -> Xml.token Stream.t
-
-(* |+* level 1 -> xml stream
- * @param ids_to_uris +|
-val render_to_boxml:
- (Cic.id, string) Hashtbl.t -> CicNotationPt.term -> Xml.token Stream.t *)
-
-val print_box: boxml_markup -> Xml.token Stream.t
-val print_mpres: mathml_markup -> Xml.token Stream.t
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(** CIC Notation Parse Tree *)
-
-type binder_kind = [ `Lambda | `Pi | `Exists | `Forall ]
-type induction_kind = [ `Inductive | `CoInductive ]
-type sort_kind = [ `Prop | `Set | `Type of CicUniv.universe | `CProp ]
-type fold_kind = [ `Left | `Right ]
-
-type location = Token.flocation
-let fail floc msg =
- let (x, y) = HExtlib.loc_of_floc floc in
- failwith (Printf.sprintf "Error at characters %d - %d: %s" x y msg)
-
-type href = UriManager.uri
-
-type child_pos = [ `Left | `Right | `Inner ]
-
-type term_attribute =
- [ `Loc of location (* source file location *)
- | `IdRef of string (* ACic pointer *)
- | `Level of int * Gramext.g_assoc (* precedence, associativity *)
- | `ChildPos of child_pos (* position of l1 pattern variables *)
- | `XmlAttrs of (string option * string * string) list
- (* list of XML attributes: namespace, name, value *)
- | `Raw of string (* unparsed version *)
- ]
-
-type literal =
- [ `Symbol of string
- | `Keyword of string
- | `Number of string
- ]
-
-type case_indtype = string * href option
-
-(** To be increased each time the term type below changes, used for "safe"
- * marshalling *)
-let magic = 1
-
-type term =
- (* CIC AST *)
-
- | AttributedTerm of term_attribute * term
-
- | Appl of term list
- | Binder of binder_kind * capture_variable * term (* kind, name, body *)
- | Case of term * case_indtype option * term option *
- (case_pattern * term) list
- (* what to match, inductive type, out type, <pattern,action> list *)
- | Cast of term * term
- | LetIn of capture_variable * term * term (* name, body, where *)
- | LetRec of induction_kind * (capture_variable * term * int) list * term
- (* (name, body, decreasing argument) list, where *)
- | Ident of string * subst list option
- (* literal, substitutions.
- * Some [] -> user has given an empty explicit substitution list
- * None -> user has given no explicit substitution list *)
- | Implicit
- | Meta of int * meta_subst list
- | Num of string * int (* literal, instance *)
- | Sort of sort_kind
- | Symbol of string * int (* canonical name, instance *)
-
- | UserInput (* place holder for user input, used by MatitaConsole, not to be
- used elsewhere *)
- | Uri of string * subst list option (* as Ident, for long names *)
-
- (* Syntax pattern extensions *)
-
- | Literal of literal
- | Layout of layout_pattern
-
- | Magic of magic_term
- | Variable of pattern_variable
-
- (* name, type. First component must be Ident or Variable (FreshVar _) *)
-and capture_variable = term * term option
-
-and meta_subst = term option
-and subst = string * term
-and case_pattern = string * href option * capture_variable list
-
-and box_kind = H | V | HV | HOV
-and box_spec = box_kind * bool * bool (* kind, spacing, indent *)
-
-and layout_pattern =
- | Sub of term * term
- | Sup of term * term
- | Below of term * term
- | Above of term * term
- | Frac of term * term
- | Over of term * term
- | Atop of term * term
-(* | array of term * literal option * literal option
- |+ column separator, row separator +| *)
- | Sqrt of term
- | Root of term * term (* argument, index *)
- | Break
- | Box of box_spec * term list
- | Group of term list
-
-and magic_term =
- (* level 1 magics *)
- | List0 of term * literal option (* pattern, separator *)
- | List1 of term * literal option (* pattern, separator *)
- | Opt of term
-
- (* level 2 magics *)
- | Fold of fold_kind * term * string list * term
- (* base case pattern, recursive case bound names, recursive case pattern *)
- | Default of term * term (* "some" case pattern, "none" case pattern *)
- | Fail
- | If of term * term * term (* test, pattern if true, pattern if false *)
-
-and pattern_variable =
- (* level 1 and 2 variables *)
- | NumVar of string
- | IdentVar of string
- | TermVar of string
-
- (* level 1 variables *)
- | Ascription of term * string
-
- (* level 2 variables *)
- | FreshVar of string
-
-type argument_pattern =
- | IdentArg of int * string (* eta-depth, name *)
-
-type cic_appl_pattern =
- | UriPattern of UriManager.uri
- | VarPattern of string
- | ImplicitPattern
- | ApplPattern of cic_appl_pattern list
-
-(** {2 Standard precedences} *)
-
-let let_in_prec = 10
-let binder_prec = 20
-let apply_prec = 70
-let simple_prec = 90
-
-let let_in_assoc = Gramext.NonA
-let binder_assoc = Gramext.RightA
-let apply_assoc = Gramext.LeftA
-let simple_assoc = Gramext.NonA
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Printf
-
-module Ast = CicNotationPt
-
-let debug = false
-let debug_print s = if debug then prerr_endline (Lazy.force s) else ()
-
-type pattern_id = int
-type interpretation_id = pattern_id
-type pretty_printer_id = pattern_id
-
-type term_info =
- { sort: (Cic.id, Ast.sort_kind) Hashtbl.t;
- uri: (Cic.id, UriManager.uri) Hashtbl.t;
- }
-
-let get_types uri =
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- | Cic.InductiveDefinition (l,_,_,_) -> l
- | _ -> assert false
-
-let name_of_inductive_type uri i =
- let types = get_types uri in
- let (name, _, _, _) = try List.nth types i with Not_found -> assert false in
- name
-
- (* returns <name, type> pairs *)
-let constructors_of_inductive_type uri i =
- let types = get_types uri in
- let (_, _, _, constructors) =
- try List.nth types i with Not_found -> assert false
- in
- constructors
-
- (* returns name only *)
-let constructor_of_inductive_type uri i j =
- (try
- fst (List.nth (constructors_of_inductive_type uri i) (j-1))
- with Not_found -> assert false)
-
-let idref id t = Ast.AttributedTerm (`IdRef id, t)
-
-let resolve_binder = function
- | `Lambda -> "\\lambda"
- | `Pi -> "\\Pi"
- | `Forall -> "\\forall"
- | `Exists -> "\\exists"
-
-let add_level_info prec assoc t = Ast.AttributedTerm (`Level (prec, assoc), t)
-let add_pos_info pos t = Ast.AttributedTerm (`ChildPos pos, t)
-let left_pos = add_pos_info `Left
-let right_pos = add_pos_info `Right
-let inner_pos = add_pos_info `Inner
-
-let rec top_pos t = add_level_info ~-1 Gramext.NonA (inner_pos t)
-(* function
- | Ast.AttributedTerm (`Level _, t) ->
- add_level_info ~-1 Gramext.NonA (inner_pos t)
- | Ast.AttributedTerm (attr, t) -> Ast.AttributedTerm (attr, top_pos t)
- | t -> add_level_info ~-1 Gramext.NonA (inner_pos t) *)
-
-let rec remove_level_info =
- function
- | Ast.AttributedTerm (`Level _, t) -> remove_level_info t
- | Ast.AttributedTerm (a, t) -> Ast.AttributedTerm (a, remove_level_info t)
- | t -> t
-
-let add_xml_attrs attrs t =
- if attrs = [] then t else Ast.AttributedTerm (`XmlAttrs attrs, t)
-
-let add_keyword_attrs =
- add_xml_attrs (RenderingAttrs.keyword_attributes `MathML)
-
-let box kind spacing indent content =
- Ast.Layout (Ast.Box ((kind, spacing, indent), content))
-
-let hbox = box Ast.H
-let vbox = box Ast.V
-let hvbox = box Ast.HV
-let hovbox = box Ast.HOV
-let break = Ast.Layout Ast.Break
-let builtin_symbol s = Ast.Literal (`Symbol s)
-let keyword k = add_keyword_attrs (Ast.Literal (`Keyword k))
-
-let number s =
- add_xml_attrs (RenderingAttrs.number_attributes `MathML)
- (Ast.Literal (`Number s))
-
-let ident i =
- add_xml_attrs (RenderingAttrs.ident_attributes `MathML) (Ast.Ident (i, None))
-
-let ident_w_href href i =
- match href with
- | None -> ident i
- | Some href ->
- let href = UriManager.string_of_uri href in
- add_xml_attrs [Some "xlink", "href", href] (ident i)
-
-let binder_symbol s =
- add_xml_attrs (RenderingAttrs.builtin_symbol_attributes `MathML)
- (builtin_symbol s)
-
-let string_of_sort_kind = function
- | `Prop -> "Prop"
- | `Set -> "Set"
- | `CProp -> "CProp"
- | `Type _ -> "Type"
-
-let pp_ast0 t k =
- let rec aux =
- function
- | Ast.Appl ts ->
- let rec aux_args pos =
- function
- | [] -> []
- | [ last ] ->
- let last = k last in
- if pos = `Left then [ left_pos last ] else [ right_pos last ]
- | hd :: tl ->
- (add_pos_info pos (k hd)) :: aux_args `Inner tl
- in
- add_level_info Ast.apply_prec Ast.apply_assoc
- (hovbox true true (CicNotationUtil.dress break (aux_args `Left ts)))
- | Ast.Binder (binder_kind, (id, ty), body) ->
- add_level_info Ast.binder_prec Ast.binder_assoc
- (hvbox false true
- [ binder_symbol (resolve_binder binder_kind);
- k id; builtin_symbol ":"; aux_ty ty; break;
- builtin_symbol "."; right_pos (k body) ])
- | Ast.Case (what, indty_opt, outty_opt, patterns) ->
- let outty_box =
- match outty_opt with
- | None -> []
- | Some outty ->
- [ keyword "return"; break; remove_level_info (k outty)]
- in
- let indty_box =
- match indty_opt with
- | None -> []
- | Some (indty, href) -> [ keyword "in"; break; ident_w_href href indty ]
- in
- let match_box =
- hvbox false false [
- hvbox false true [
- hvbox false true [ keyword "match"; break; top_pos (k what) ];
- break;
- hvbox false true indty_box;
- break;
- hvbox false true outty_box
- ];
- break;
- keyword "with"
- ]
- in
- let mk_case_pattern (head, href, vars) =
- hbox true false (ident_w_href href head :: List.map aux_var vars)
- in
- let patterns' =
- List.map
- (fun (lhs, rhs) ->
- remove_level_info
- (hvbox false true [
- hbox false true [
- mk_case_pattern lhs; builtin_symbol "\\Rightarrow" ];
- break; top_pos (k rhs) ]))
- patterns
- in
- let patterns'' =
- let rec aux_patterns = function
- | [] -> assert false
- | [ last ] ->
- [ break;
- hbox false false [
- builtin_symbol "|";
- last; builtin_symbol "]" ] ]
- | hd :: tl ->
- [ break; hbox false false [ builtin_symbol "|"; hd ] ]
- @ aux_patterns tl
- in
- match patterns' with
- | [] ->
- [ hbox false false [ builtin_symbol "["; builtin_symbol "]" ] ]
- | [ one ] ->
- [ hbox false false [
- builtin_symbol "["; one; builtin_symbol "]" ] ]
- | hd :: tl ->
- hbox false false [ builtin_symbol "["; hd ]
- :: aux_patterns tl
- in
- add_level_info Ast.simple_prec Ast.simple_assoc
- (hvbox false false [
- hvbox false false ([match_box]); break;
- hbox false false [ hvbox false false patterns'' ] ])
- | Ast.Cast (bo, ty) ->
- add_level_info Ast.simple_prec Ast.simple_assoc
- (hvbox false true [
- builtin_symbol "("; top_pos (k bo); break; builtin_symbol ":";
- top_pos (k ty); builtin_symbol ")"])
- | Ast.LetIn (var, s, t) ->
- add_level_info Ast.let_in_prec Ast.let_in_assoc
- (hvbox false true [
- hvbox false true [
- keyword "let";
- hvbox false true [
- aux_var var; builtin_symbol "\\def"; break; top_pos (k s) ];
- break; keyword "in" ];
- break;
- k t ])
- | Ast.LetRec (rec_kind, funs, where) ->
- let rec_op =
- match rec_kind with `Inductive -> "rec" | `CoInductive -> "corec"
- in
- let mk_fun (var, body, _) = aux_var var, k body in
- let mk_funs = List.map mk_fun in
- let fst_fun, tl_funs =
- match mk_funs funs with hd :: tl -> hd, tl | [] -> assert false
- in
- let fst_row =
- let (name, body) = fst_fun in
- hvbox false true [
- keyword "let"; keyword rec_op; name; builtin_symbol "\\def"; break;
- top_pos body ]
- in
- let tl_rows =
- List.map
- (fun (name, body) ->
- [ break;
- hvbox false true [
- keyword "and"; name; builtin_symbol "\\def"; break; body ] ])
- tl_funs
- in
- add_level_info Ast.let_in_prec Ast.let_in_assoc
- ((hvbox false false
- (fst_row :: List.flatten tl_rows
- @ [ break; keyword "in"; break; k where ])))
- | Ast.Implicit -> builtin_symbol "?"
- | Ast.Meta (n, l) ->
- let local_context l =
- CicNotationUtil.dress (builtin_symbol ";")
- (List.map (function None -> builtin_symbol "_" | Some t -> k t) l)
- in
- hbox false false
- ([ builtin_symbol "?"; number (string_of_int n) ]
- @ (if l <> [] then local_context l else []))
- | Ast.Sort sort -> aux_sort sort
- | Ast.Num _
- | Ast.Symbol _
- | Ast.Ident (_, None) | Ast.Ident (_, Some [])
- | Ast.Uri (_, None) | Ast.Uri (_, Some [])
- | Ast.Literal _
- | Ast.UserInput as leaf -> leaf
- | t -> CicNotationUtil.visit_ast ~special_k k t
- and aux_sort sort_kind =
- add_xml_attrs (RenderingAttrs.keyword_attributes `MathML)
- (Ast.Ident (string_of_sort_kind sort_kind, None))
- and aux_ty = function
- | None -> builtin_symbol "?"
- | Some ty -> k ty
- and aux_var = function
- | name, Some ty ->
- hvbox false true [
- builtin_symbol "("; name; builtin_symbol ":"; break; k ty;
- builtin_symbol ")" ]
- | name, None -> name
- and special_k = function
- | Ast.AttributedTerm (attrs, t) -> Ast.AttributedTerm (attrs, k t)
- | t ->
- prerr_endline ("unexpected special: " ^ CicNotationPp.pp_term t);
- assert false
- in
- aux t
-
-let ast_of_acic0 term_info acic k =
- let k = k term_info in
- let id_to_uris = term_info.uri in
- let register_uri id uri = Hashtbl.add id_to_uris id uri in
- let sort_of_id id =
- try
- Hashtbl.find term_info.sort id
- with Not_found ->
- prerr_endline (sprintf "warning: sort of id %s not found, using Type" id);
- `Type (CicUniv.fresh ())
- in
- let aux_substs substs =
- Some
- (List.map
- (fun (uri, annterm) -> (UriManager.name_of_uri uri, k annterm))
- substs)
- in
- let aux_context context =
- List.map
- (function
- | None -> None
- | Some annterm -> Some (k annterm))
- context
- in
- let aux = function
- | Cic.ARel (id,_,_,b) -> idref id (Ast.Ident (b, None))
- | Cic.AVar (id,uri,substs) ->
- register_uri id uri;
- idref id (Ast.Ident (UriManager.name_of_uri uri, aux_substs substs))
- | Cic.AMeta (id,n,l) -> idref id (Ast.Meta (n, aux_context l))
- | Cic.ASort (id,Cic.Prop) -> idref id (Ast.Sort `Prop)
- | Cic.ASort (id,Cic.Set) -> idref id (Ast.Sort `Set)
- | Cic.ASort (id,Cic.Type u) -> idref id (Ast.Sort (`Type u))
- | Cic.ASort (id,Cic.CProp) -> idref id (Ast.Sort `CProp)
- | Cic.AImplicit (id, Some `Hole) -> idref id Ast.UserInput
- | Cic.AImplicit (id, _) -> idref id Ast.Implicit
- | Cic.AProd (id,n,s,t) ->
- let binder_kind =
- match sort_of_id id with
- | `Set | `Type _ -> `Pi
- | `Prop | `CProp -> `Forall
- in
- idref id (Ast.Binder (binder_kind,
- (CicNotationUtil.name_of_cic_name n, Some (k s)), k t))
- | Cic.ACast (id,v,t) -> idref id (Ast.Cast (k v, k t))
- | Cic.ALambda (id,n,s,t) ->
- idref id (Ast.Binder (`Lambda,
- (CicNotationUtil.name_of_cic_name n, Some (k s)), k t))
- | Cic.ALetIn (id,n,s,t) ->
- idref id (Ast.LetIn ((CicNotationUtil.name_of_cic_name n, None),
- k s, k t))
- | Cic.AAppl (aid,args) -> idref aid (Ast.Appl (List.map k args))
- | Cic.AConst (id,uri,substs) ->
- register_uri id uri;
- idref id (Ast.Ident (UriManager.name_of_uri uri, aux_substs substs))
- | Cic.AMutInd (id,uri,i,substs) as t ->
- let name = name_of_inductive_type uri i in
- let uri_str = UriManager.string_of_uri uri in
- let puri_str = sprintf "%s#xpointer(1/%d)" uri_str (i+1) in
- register_uri id (UriManager.uri_of_string puri_str);
- idref id (Ast.Ident (name, aux_substs substs))
- | Cic.AMutConstruct (id,uri,i,j,substs) ->
- let name = constructor_of_inductive_type uri i j in
- let uri_str = UriManager.string_of_uri uri in
- let puri_str = sprintf "%s#xpointer(1/%d/%d)" uri_str (i + 1) j in
- register_uri id (UriManager.uri_of_string puri_str);
- idref id (Ast.Ident (name, aux_substs substs))
- | Cic.AMutCase (id,uri,typeno,ty,te,patterns) ->
- let name = name_of_inductive_type uri typeno in
- let uri_str = UriManager.string_of_uri uri in
- let puri_str = sprintf "%s#xpointer(1/%d)" uri_str (typeno+1) in
- let ctor_puri j =
- UriManager.uri_of_string
- (sprintf "%s#xpointer(1/%d/%d)" uri_str (typeno+1) j)
- in
- let case_indty = name, Some (UriManager.uri_of_string puri_str) in
- let constructors = constructors_of_inductive_type uri typeno in
- let rec eat_branch ty pat =
- match (ty, pat) with
- | Cic.Prod (_, _, t), Cic.ALambda (_, name, s, t') ->
- let (cv, rhs) = eat_branch t t' in
- (CicNotationUtil.name_of_cic_name name, Some (k s)) :: cv, rhs
- | _, _ -> [], k pat
- in
- let j = ref 0 in
- let patterns =
- try
- List.map2
- (fun (name, ty) pat ->
- incr j;
- let (capture_variables, rhs) = eat_branch ty pat in
- ((name, Some (ctor_puri !j), capture_variables), rhs))
- constructors patterns
- with Invalid_argument _ -> assert false
- in
- idref id (Ast.Case (k te, Some case_indty, Some (k ty), patterns))
- | Cic.AFix (id, no, funs) ->
- let defs =
- List.map
- (fun (_, n, decr_idx, ty, bo) ->
- ((Ast.Ident (n, None), Some (k ty)), k bo, decr_idx))
- funs
- in
- let name =
- try
- (match List.nth defs no with
- | (Ast.Ident (n, _), _), _, _ when n <> "_" -> n
- | _ -> assert false)
- with Not_found -> assert false
- in
- idref id (Ast.LetRec (`Inductive, defs, Ast.Ident (name, None)))
- | Cic.ACoFix (id, no, funs) ->
- let defs =
- List.map
- (fun (_, n, ty, bo) ->
- ((Ast.Ident (n, None), Some (k ty)), k bo, 0))
- funs
- in
- let name =
- try
- (match List.nth defs no with
- | (Ast.Ident (n, _), _), _, _ when n <> "_" -> n
- | _ -> assert false)
- with Not_found -> assert false
- in
- idref id (Ast.LetRec (`CoInductive, defs, Ast.Ident (name, None)))
- in
- aux acic
-
- (* persistent state *)
-
-let level1_patterns21 = Hashtbl.create 211
-let level2_patterns32 = Hashtbl.create 211
-let interpretations = Hashtbl.create 211 (* symb -> id list ref *)
-
-let compiled21 = ref None
-let compiled32 = ref None
-
-let pattern21_matrix = ref []
-let pattern32_matrix = ref []
-
-let get_compiled21 () =
- match !compiled21 with
- | None -> assert false
- | Some f -> Lazy.force f
-let get_compiled32 () =
- match !compiled32 with
- | None -> assert false
- | Some f -> Lazy.force f
-
-let set_compiled21 f = compiled21 := Some f
-let set_compiled32 f = compiled32 := Some f
-
-let add_idrefs =
- List.fold_right (fun idref t -> Ast.AttributedTerm (`IdRef idref, t))
-
-let instantiate21 idrefs env l1 =
- let rec subst_singleton pos env =
- function
- Ast.AttributedTerm (attr, t) ->
- Ast.AttributedTerm (attr, subst_singleton pos env t)
- | t -> CicNotationUtil.group (subst pos env t)
- and subst pos env = function
- | Ast.AttributedTerm (attr, t) as term ->
-(* prerr_endline ("loosing attribute " ^ CicNotationPp.pp_attribute attr); *)
- subst pos env t
- | Ast.Variable var ->
- let name, expected_ty = CicNotationEnv.declaration_of_var var in
- let ty, value =
- try
- List.assoc name env
- with Not_found ->
- prerr_endline ("name " ^ name ^ " not found in environment");
- assert false
- in
- assert (CicNotationEnv.well_typed ty value); (* INVARIANT *)
- (* following assertion should be a conditional that makes this
- * instantiation fail *)
- assert (CicNotationEnv.well_typed expected_ty value);
- [ add_pos_info pos (CicNotationEnv.term_of_value value) ]
- | Ast.Magic m -> subst_magic pos env m
- | Ast.Literal l as t ->
- let t = add_idrefs idrefs t in
- (match l with
- | `Keyword k -> [ add_keyword_attrs t ]
- | _ -> [ t ])
- | Ast.Layout l -> [ Ast.Layout (subst_layout pos env l) ]
- | t -> [ CicNotationUtil.visit_ast (subst_singleton pos env) t ]
- and subst_magic pos env = function
- | Ast.List0 (p, sep_opt)
- | Ast.List1 (p, sep_opt) ->
- let rec_decls = CicNotationEnv.declarations_of_term p in
- let rec_values =
- List.map (fun (n, _) -> CicNotationEnv.lookup_list env n) rec_decls
- in
- let values = CicNotationUtil.ncombine rec_values in
- let sep =
- match sep_opt with
- | None -> []
- | Some l -> [ Ast.Literal l ]
- in
- let rec instantiate_list acc = function
- | [] -> List.rev acc
- | value_set :: [] ->
- let env = CicNotationEnv.combine rec_decls value_set in
- instantiate_list (CicNotationUtil.group (subst pos env p) :: acc)
- []
- | value_set :: tl ->
- let env = CicNotationEnv.combine rec_decls value_set in
- let terms = subst pos env p in
- instantiate_list (CicNotationUtil.group (terms @ sep) :: acc) tl
- in
- instantiate_list [] values
- | Ast.Opt p ->
- let opt_decls = CicNotationEnv.declarations_of_term p in
- let env =
- let rec build_env = function
- | [] -> []
- | (name, ty) :: tl ->
- (* assumption: if one of the value is None then all are *)
- (match CicNotationEnv.lookup_opt env name with
- | None -> raise Exit
- | Some v -> (name, (ty, v)) :: build_env tl)
- in
- try build_env opt_decls with Exit -> []
- in
- begin
- match env with
- | [] -> []
- | _ -> subst pos env p
- end
- | _ -> assert false (* impossible *)
- and subst_layout pos env = function
- | Ast.Box (kind, tl) ->
- let tl' = subst_children pos env tl in
- Ast.Box (kind, List.concat tl')
- | l -> CicNotationUtil.visit_layout (subst_singleton pos env) l
- and subst_children pos env =
- function
- | [] -> []
- | [ child ] ->
- let pos' =
- match pos with
- | `Inner -> `Right
- | `Left -> `Left
-(* | `None -> assert false *)
- | `Right -> `Right
- in
- [ subst pos' env child ]
- | hd :: tl ->
- let pos' =
- match pos with
- | `Inner -> `Inner
- | `Left -> `Inner
-(* | `None -> assert false *)
- | `Right -> `Right
- in
- (subst pos env hd) :: subst_children pos' env tl
- in
- subst_singleton `Left env l1
-
-let rec pp_ast1 term =
- let rec pp_value = function
- | CicNotationEnv.NumValue _ as v -> v
- | CicNotationEnv.StringValue _ as v -> v
-(* | CicNotationEnv.TermValue t when t == term -> CicNotationEnv.TermValue (pp_ast0 t pp_ast1) *)
- | CicNotationEnv.TermValue t -> CicNotationEnv.TermValue (pp_ast1 t)
- | CicNotationEnv.OptValue None as v -> v
- | CicNotationEnv.OptValue (Some v) ->
- CicNotationEnv.OptValue (Some (pp_value v))
- | CicNotationEnv.ListValue vl ->
- CicNotationEnv.ListValue (List.map pp_value vl)
- in
- let ast_env_of_env env =
- List.map (fun (var, (ty, value)) -> (var, (ty, pp_value value))) env
- in
-(* prerr_endline ("pattern matching from 2 to 1 on term " ^ CicNotationPp.pp_term term); *)
- match term with
- | Ast.AttributedTerm (attrs, term') ->
- Ast.AttributedTerm (attrs, pp_ast1 term')
- | _ ->
- (match (get_compiled21 ()) term with
- | None -> pp_ast0 term pp_ast1
- | Some (env, ctors, pid) ->
- let idrefs =
- List.flatten (List.map CicNotationUtil.get_idrefs ctors)
- in
- let l1 =
- try
- Hashtbl.find level1_patterns21 pid
- with Not_found -> assert false
- in
- instantiate21 idrefs (ast_env_of_env env) l1)
-
-let instantiate32 term_info idrefs env symbol args =
- let rec instantiate_arg = function
- | Ast.IdentArg (n, name) ->
- let t = (try List.assoc name env with Not_found -> assert false) in
- let rec count_lambda = function
- | Ast.AttributedTerm (_, t) -> count_lambda t
- | Ast.Binder (`Lambda, _, body) -> 1 + count_lambda body
- | _ -> 0
- in
- let rec add_lambda t n =
- if n > 0 then
- let name = CicNotationUtil.fresh_name () in
- Ast.Binder (`Lambda, (Ast.Ident (name, None), None),
- Ast.Appl [add_lambda t (n - 1); Ast.Ident (name, None)])
- else
- t
- in
- add_lambda t (n - count_lambda t)
- in
- let head =
- let symbol = Ast.Symbol (symbol, 0) in
- add_idrefs idrefs symbol
- in
- if args = [] then head
- else Ast.Appl (head :: List.map instantiate_arg args)
-
-let rec ast_of_acic1 term_info annterm =
- let id_to_uris = term_info.uri in
- let register_uri id uri = Hashtbl.add id_to_uris id uri in
- match (get_compiled32 ()) annterm with
- | None -> ast_of_acic0 term_info annterm ast_of_acic1
- | Some (env, ctors, pid) ->
- let idrefs =
- List.map
- (fun annterm ->
- let idref = CicUtil.id_of_annterm annterm in
- (try
- register_uri idref
- (CicUtil.uri_of_term (Deannotate.deannotate_term annterm))
- with Invalid_argument _ -> ());
- idref)
- ctors
- in
- let env' =
- List.map (fun (name, term) -> (name, ast_of_acic1 term_info term)) env
- in
- let _, symbol, args, _ =
- try
- Hashtbl.find level2_patterns32 pid
- with Not_found -> assert false
- in
- let ast = instantiate32 term_info idrefs env' symbol args in
- Ast.AttributedTerm (`IdRef (CicUtil.id_of_annterm annterm), ast)
-
-let load_patterns32 t =
- let t =
- HExtlib.filter_map (function (true, ap, id) -> Some (ap, id) | _ -> None) t
- in
- set_compiled32 (lazy (CicNotationMatcher.Matcher32.compiler t))
-
-let load_patterns21 t =
- set_compiled21 (lazy (CicNotationMatcher.Matcher21.compiler t))
-
-let ast_of_acic id_to_sort annterm =
- debug_print (lazy ("ast_of_acic <- "
- ^ CicPp.ppterm (Deannotate.deannotate_term annterm)));
- let term_info = { sort = id_to_sort; uri = Hashtbl.create 211 } in
- let ast = ast_of_acic1 term_info annterm in
- debug_print (lazy ("ast_of_acic -> " ^ CicNotationPp.pp_term ast));
- ast, term_info.uri
-
-let pp_ast ast =
- debug_print (lazy "pp_ast <-");
- let ast' = pp_ast1 ast in
- debug_print (lazy ("pp_ast -> " ^ CicNotationPp.pp_term ast'));
- ast'
-
-let fresh_id =
- let counter = ref ~-1 in
- fun () ->
- incr counter;
- !counter
-
-let add_interpretation dsc (symbol, args) appl_pattern =
- let id = fresh_id () in
- Hashtbl.add level2_patterns32 id (dsc, symbol, args, appl_pattern);
- pattern32_matrix := (true, appl_pattern, id) :: !pattern32_matrix;
- load_patterns32 !pattern32_matrix;
- (try
- let ids = Hashtbl.find interpretations symbol in
- ids := id :: !ids
- with Not_found -> Hashtbl.add interpretations symbol (ref [id]));
- id
-
-let get_all_interpretations () =
- List.map
- (function (_, _, id) ->
- let (dsc, _, _, _) =
- try
- Hashtbl.find level2_patterns32 id
- with Not_found -> assert false
- in
- (id, dsc))
- !pattern32_matrix
-
-let get_active_interpretations () =
- HExtlib.filter_map (function (true, _, id) -> Some id | _ -> None)
- !pattern32_matrix
-
-let set_active_interpretations ids =
- let pattern32_matrix' =
- List.map
- (function
- | (_, ap, id) when List.mem id ids -> (true, ap, id)
- | (_, ap, id) -> (false, ap, id))
- !pattern32_matrix
- in
- pattern32_matrix := pattern32_matrix';
- load_patterns32 !pattern32_matrix
-
-exception Interpretation_not_found
-exception Pretty_printer_not_found
-
-let rec list_uniq = function
- | [] -> []
- | h::[] -> [h]
- | h1::h2::tl when h1 = h2 -> list_uniq (h2 :: tl)
- | h1::tl (* when h1 <> h2 *) -> h1 :: list_uniq tl
-
-let lookup_interpretations symbol =
- try
- list_uniq
- (List.sort Pervasives.compare
- (List.map
- (fun id ->
- let (dsc, _, args, appl_pattern) =
- try
- Hashtbl.find level2_patterns32 id
- with Not_found -> assert false
- in
- dsc, args, appl_pattern)
- !(Hashtbl.find interpretations symbol)))
- with Not_found -> raise Interpretation_not_found
-
-let fill_pos_info l1_pattern = l1_pattern
-(* let rec aux toplevel pos =
- function
- | Ast.Layout l ->
- (match l
-
- | Ast.Magic m ->
- Ast.Box (
- | Ast.Variable _ as t -> add_pos_info pos t
- | t -> t
- in
- aux true l1_pattern *)
-
-let add_pretty_printer ~precedence ~associativity l2 l1 =
- let id = fresh_id () in
- let l1' = add_level_info precedence associativity (fill_pos_info l1) in
- let l2' = CicNotationUtil.strip_attributes l2 in
- Hashtbl.add level1_patterns21 id l1';
- pattern21_matrix := (l2', id) :: !pattern21_matrix;
- load_patterns21 !pattern21_matrix;
- id
-
-let remove_interpretation id =
- (try
- let _, symbol, _, _ = Hashtbl.find level2_patterns32 id in
- let ids = Hashtbl.find interpretations symbol in
- ids := List.filter ((<>) id) !ids;
- Hashtbl.remove level2_patterns32 id;
- with Not_found -> raise Interpretation_not_found);
- pattern32_matrix :=
- List.filter (fun (_, _, id') -> id <> id') !pattern32_matrix;
- load_patterns32 !pattern32_matrix
-
-let remove_pretty_printer id =
- (try
- Hashtbl.remove level1_patterns21 id;
- with Not_found -> raise Pretty_printer_not_found);
- pattern21_matrix := List.filter (fun (_, id') -> id <> id') !pattern21_matrix;
- load_patterns21 !pattern21_matrix
-
-let _ =
- load_patterns21 [];
- load_patterns32 []
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
- (** level 3 -> level 2 *)
-val ast_of_acic:
- (Cic.id, CicNotationPt.sort_kind) Hashtbl.t -> (* id -> sort *)
- Cic.annterm -> (* acic *)
- CicNotationPt.term (* ast *)
- * (Cic.id, UriManager.uri) Hashtbl.t (* id -> uri *)
-
- (** level 2 -> level 1 *)
-val pp_ast: CicNotationPt.term -> CicNotationPt.term
-
- (** for level 1 -> level 0: see CicNotationPres.render *)
-
-type interpretation_id
-type pretty_printer_id
-
-val add_interpretation:
- string -> (* id / description *)
- string * CicNotationPt.argument_pattern list -> (* symbol, level 2 pattern *)
- CicNotationPt.cic_appl_pattern -> (* level 3 pattern *)
- interpretation_id
-
- (** @raise Interpretation_not_found *)
-val lookup_interpretations:
- string -> (* symbol *)
- (string * CicNotationPt.argument_pattern list *
- CicNotationPt.cic_appl_pattern) list
-
-val add_pretty_printer:
- precedence:int ->
- associativity:Gramext.g_assoc ->
- CicNotationPt.term -> (* level 2 pattern *)
- CicNotationPt.term -> (* level 1 pattern *)
- pretty_printer_id
-
-exception Interpretation_not_found
-exception Pretty_printer_not_found
-
- (** @raise Interpretation_not_found *)
-val remove_interpretation: interpretation_id -> unit
-
- (** @raise Pretty_printer_not_found *)
-val remove_pretty_printer: pretty_printer_id -> unit
-
-(** {2 Interpretations toggling} *)
-
-val get_all_interpretations: unit -> (interpretation_id * string) list
-val get_active_interpretations: unit -> interpretation_id list
-val set_active_interpretations: interpretation_id list -> unit
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-module Ast = CicNotationPt
-
-type tag = int
-type pattern_t = Ast.term
-
-let get_tag term0 =
- let subterms = ref [] in
- let map_term t =
- subterms := t :: !subterms ;
- Ast.Implicit
- in
- let rec aux t = CicNotationUtil.visit_ast ~special_k map_term t
- and special_k = function
- | Ast.AttributedTerm (_, t) -> aux t
- | _ -> assert false
- in
- let term_mask = aux term0 in
- let tag = Hashtbl.hash term_mask in
- tag, List.rev !subterms
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-val get_tag: CicNotationPt.term -> int * CicNotationPt.term list
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-module Ast = CicNotationPt
-
-let visit_ast ?(special_k = fun _ -> assert false) k =
- let rec aux = function
- | Ast.Appl terms -> Ast.Appl (List.map k terms)
- | Ast.Binder (kind, var, body) ->
- Ast.Binder (kind, aux_capture_variable var, k body)
- | Ast.Case (term, indtype, typ, patterns) ->
- Ast.Case (k term, indtype, aux_opt typ, aux_patterns patterns)
- | Ast.Cast (t1, t2) -> Ast.Cast (k t1, k t2)
- | Ast.LetIn (var, t1, t2) ->
- Ast.LetIn (aux_capture_variable var, k t1, k t2)
- | Ast.LetRec (kind, definitions, term) ->
- let definitions =
- List.map
- (fun (var, ty, n) -> aux_capture_variable var, k ty, n)
- definitions
- in
- Ast.LetRec (kind, definitions, k term)
- | Ast.Ident (name, Some substs) ->
- Ast.Ident (name, Some (aux_substs substs))
- | Ast.Uri (name, Some substs) -> Ast.Uri (name, Some (aux_substs substs))
- | Ast.Meta (index, substs) -> Ast.Meta (index, List.map aux_opt substs)
- | (Ast.AttributedTerm _
- | Ast.Layout _
- | Ast.Literal _
- | Ast.Magic _
- | Ast.Variable _) as t -> special_k t
- | (Ast.Ident _
- | Ast.Implicit
- | Ast.Num _
- | Ast.Sort _
- | Ast.Symbol _
- | Ast.Uri _
- | Ast.UserInput) as t -> t
- and aux_opt = function
- | None -> None
- | Some term -> Some (k term)
- and aux_capture_variable (term, typ_opt) = k term, aux_opt typ_opt
- and aux_patterns patterns = List.map aux_pattern patterns
- and aux_pattern ((head, hrefs, vars), term) =
- ((head, hrefs, List.map aux_capture_variable vars), k term)
- and aux_subst (name, term) = (name, k term)
- and aux_substs substs = List.map aux_subst substs
- in
- aux
-
-let visit_layout k = function
- | Ast.Sub (t1, t2) -> Ast.Sub (k t1, k t2)
- | Ast.Sup (t1, t2) -> Ast.Sup (k t1, k t2)
- | Ast.Below (t1, t2) -> Ast.Below (k t1, k t2)
- | Ast.Above (t1, t2) -> Ast.Above (k t1, k t2)
- | Ast.Over (t1, t2) -> Ast.Over (k t1, k t2)
- | Ast.Atop (t1, t2) -> Ast.Atop (k t1, k t2)
- | Ast.Frac (t1, t2) -> Ast.Frac (k t1, k t2)
- | Ast.Sqrt t -> Ast.Sqrt (k t)
- | Ast.Root (arg, index) -> Ast.Root (k arg, k index)
- | Ast.Break -> Ast.Break
- | Ast.Box (kind, terms) -> Ast.Box (kind, List.map k terms)
- | Ast.Group terms -> Ast.Group (List.map k terms)
-
-let visit_magic k = function
- | Ast.List0 (t, l) -> Ast.List0 (k t, l)
- | Ast.List1 (t, l) -> Ast.List1 (k t, l)
- | Ast.Opt t -> Ast.Opt (k t)
- | Ast.Fold (kind, t1, names, t2) -> Ast.Fold (kind, k t1, names, k t2)
- | Ast.Default (t1, t2) -> Ast.Default (k t1, k t2)
- | Ast.If (t1, t2, t3) -> Ast.If (k t1, k t2, k t3)
- | Ast.Fail -> Ast.Fail
-
-let visit_variable k = function
- | Ast.NumVar _
- | Ast.IdentVar _
- | Ast.TermVar _
- | Ast.FreshVar _ as t -> t
- | Ast.Ascription (t, s) -> Ast.Ascription (k t, s)
-
-let variables_of_term t =
- let rec vars = ref [] in
- let add_variable v =
- if List.mem v !vars then ()
- else vars := v :: !vars
- in
- let rec aux = function
- | Ast.Magic m -> Ast.Magic (visit_magic aux m)
- | Ast.Layout l -> Ast.Layout (visit_layout aux l)
- | Ast.Variable v -> Ast.Variable (aux_variable v)
- | Ast.Literal _ as t -> t
- | Ast.AttributedTerm (_, t) -> aux t
- | t -> visit_ast aux t
- and aux_variable = function
- | (Ast.NumVar _
- | Ast.IdentVar _
- | Ast.TermVar _) as t ->
- add_variable t ;
- t
- | Ast.FreshVar _ as t -> t
- | Ast.Ascription _ -> assert false
- in
- ignore (aux t) ;
- !vars
-
-let names_of_term t =
- let aux = function
- | Ast.NumVar s
- | Ast.IdentVar s
- | Ast.TermVar s -> s
- | _ -> assert false
- in
- List.map aux (variables_of_term t)
-
-let keywords_of_term t =
- let rec keywords = ref [] in
- let add_keyword k = keywords := k :: !keywords in
- let rec aux = function
- | Ast.AttributedTerm (_, t) -> aux t
- | Ast.Layout l -> Ast.Layout (visit_layout aux l)
- | Ast.Literal (`Keyword k) as t ->
- add_keyword k;
- t
- | Ast.Literal _ as t -> t
- | Ast.Magic m -> Ast.Magic (visit_magic aux m)
- | Ast.Variable _ as v -> v
- | t -> visit_ast aux t
- in
- ignore (aux t) ;
- !keywords
-
-let rec strip_attributes t =
- let special_k = function
- | Ast.AttributedTerm (_, term) -> strip_attributes term
- | Ast.Magic m -> Ast.Magic (visit_magic strip_attributes m)
- | Ast.Variable _ as t -> t
- | t -> assert false
- in
- visit_ast ~special_k strip_attributes t
-
-let rec get_idrefs =
- function
- | Ast.AttributedTerm (`IdRef id, t) -> id :: get_idrefs t
- | Ast.AttributedTerm (_, t) -> get_idrefs t
- | _ -> []
-
-let meta_names_of_term term =
- let rec names = ref [] in
- let add_name n =
- if List.mem n !names then ()
- else names := n :: !names
- in
- let rec aux = function
- | Ast.AttributedTerm (_, term) -> aux term
- | Ast.Appl terms -> List.iter aux terms
- | Ast.Binder (_, _, body) -> aux body
- | Ast.Case (term, indty, outty_opt, patterns) ->
- aux term ;
- aux_opt outty_opt ;
- List.iter aux_branch patterns
- | Ast.LetIn (_, t1, t2) ->
- aux t1 ;
- aux t2
- | Ast.LetRec (_, definitions, body) ->
- List.iter aux_definition definitions ;
- aux body
- | Ast.Uri (_, Some substs) -> aux_substs substs
- | Ast.Ident (_, Some substs) -> aux_substs substs
- | Ast.Meta (_, substs) -> aux_meta_substs substs
-
- | Ast.Implicit
- | Ast.Ident _
- | Ast.Num _
- | Ast.Sort _
- | Ast.Symbol _
- | Ast.Uri _
- | Ast.UserInput -> ()
-
- | Ast.Magic magic -> aux_magic magic
- | Ast.Variable var -> aux_variable var
-
- | _ -> assert false
- and aux_opt = function
- | Some term -> aux term
- | None -> ()
- and aux_capture_var (_, ty_opt) = aux_opt ty_opt
- and aux_branch (pattern, term) =
- aux_pattern pattern ;
- aux term
- and aux_pattern (head, _, vars) =
- List.iter aux_capture_var vars
- and aux_definition (var, term, i) =
- aux_capture_var var ;
- aux term
- and aux_substs substs = List.iter (fun (_, term) -> aux term) substs
- and aux_meta_substs meta_substs = List.iter aux_opt meta_substs
- and aux_variable = function
- | Ast.NumVar name -> add_name name
- | Ast.IdentVar name -> add_name name
- | Ast.TermVar name -> add_name name
- | Ast.FreshVar _ -> ()
- | Ast.Ascription _ -> assert false
- and aux_magic = function
- | Ast.Default (t1, t2)
- | Ast.Fold (_, t1, _, t2) ->
- aux t1 ;
- aux t2
- | Ast.If (t1, t2, t3) ->
- aux t1 ;
- aux t2 ;
- aux t3
- | Ast.Fail -> ()
- | _ -> assert false
- in
- aux term ;
- !names
-
-let rectangular matrix =
- let columns = Array.length matrix.(0) in
- try
- Array.iter (fun a -> if Array.length a <> columns then raise Exit) matrix;
- true
- with Exit -> false
-
-let ncombine ll =
- let matrix = Array.of_list (List.map Array.of_list ll) in
- assert (rectangular matrix);
- let rows = Array.length matrix in
- let columns = Array.length matrix.(0) in
- let lists = ref [] in
- for j = 0 to columns - 1 do
- let l = ref [] in
- for i = 0 to rows - 1 do
- l := matrix.(i).(j) :: !l
- done;
- lists := List.rev !l :: !lists
- done;
- List.rev !lists
-
-let string_of_literal = function
- | `Symbol s
- | `Keyword s
- | `Number s -> s
-
-let boxify = function
- | [ a ] -> a
- | l -> Ast.Layout (Ast.Box ((Ast.H, false, false), l))
-
-let unboxify = function
- | Ast.Layout (Ast.Box ((Ast.H, false, false), [ a ])) -> a
- | l -> l
-
-let group = function
- | [ a ] -> a
- | l -> Ast.Layout (Ast.Group l)
-
-let ungroup =
- let rec aux acc =
- function
- [] -> List.rev acc
- | Ast.Layout (Ast.Group terms) :: terms' -> aux acc (terms @ terms')
- | term :: terms -> aux (term :: acc) terms
- in
- aux []
-
-let dress ~sep:sauce =
- let rec aux =
- function
- | [] -> []
- | [hd] -> [hd]
- | hd :: tl -> hd :: sauce :: aux tl
- in
- aux
-
-let dressn ~sep:sauces =
- let rec aux =
- function
- | [] -> []
- | [hd] -> [hd]
- | hd :: tl -> hd :: sauces @ aux tl
- in
- aux
-
-let find_appl_pattern_uris ap =
- let rec aux acc =
- function
- | Ast.UriPattern uri -> uri :: acc
- | Ast.ImplicitPattern
- | Ast.VarPattern _ -> acc
- | Ast.ApplPattern apl -> List.fold_left aux acc apl
- in
- let uris = aux [] ap in
- HExtlib.list_uniq (List.fast_sort UriManager.compare uris)
-
-let rec find_branch =
- function
- Ast.Magic (Ast.If (_, Ast.Magic Ast.Fail, t)) -> find_branch t
- | Ast.Magic (Ast.If (_, t, _)) -> find_branch t
- | t -> t
-
-let cic_name_of_name = function
- | Ast.Ident ("_", None) -> Cic.Anonymous
- | Ast.Ident (name, None) -> Cic.Name name
- | _ -> assert false
-
-let name_of_cic_name =
-(* let add_dummy_xref t = Ast.AttributedTerm (`IdRef "", t) in *)
- (* ZACK why we used to generate dummy xrefs? *)
- let add_dummy_xref t = t in
- function
- | Cic.Name s -> add_dummy_xref (Ast.Ident (s, None))
- | Cic.Anonymous -> add_dummy_xref (Ast.Ident ("_", None))
-
-let fresh_index = ref ~-1
-
-type notation_id = int
-
-let fresh_id () =
- incr fresh_index;
- !fresh_index
-
- (* TODO ensure that names generated by fresh_var do not clash with user's *)
-let fresh_name () = "fresh" ^ string_of_int (fresh_id ())
-
-let rec freshen_term ?(index = ref 0) term =
- let freshen_term = freshen_term ~index in
- let fresh_instance () = incr index; !index in
- let special_k = function
- | Ast.AttributedTerm (attr, t) -> Ast.AttributedTerm (attr, freshen_term t)
- | Ast.Layout l -> Ast.Layout (visit_layout freshen_term l)
- | Ast.Magic m -> Ast.Magic (visit_magic freshen_term m)
- | Ast.Variable v -> Ast.Variable (visit_variable freshen_term v)
- | Ast.Literal _ as t -> t
- | _ -> assert false
- in
- match term with
- | Ast.Symbol (s, instance) -> Ast.Symbol (s, fresh_instance ())
- | Ast.Num (s, instance) -> Ast.Num (s, fresh_instance ())
- | t -> visit_ast ~special_k freshen_term t
-
-let freshen_obj obj =
- let index = ref 0 in
- let freshen_term = freshen_term ~index in
- let freshen_name_ty = List.map (fun (n, t) -> (n, freshen_term t)) in
- match obj with
- | GrafiteAst.Inductive (params, indtypes) ->
- let indtypes =
- List.map
- (fun (n, co, ty, ctors) -> (n, co, ty, freshen_name_ty ctors))
- indtypes
- in
- GrafiteAst.Inductive (freshen_name_ty params, indtypes)
- | GrafiteAst.Theorem (flav, n, t, ty_opt) ->
- let ty_opt =
- match ty_opt with None -> None | Some ty -> Some (freshen_term ty)
- in
- GrafiteAst.Theorem (flav, n, freshen_term t, ty_opt)
- | GrafiteAst.Record (params, n, ty, fields) ->
- GrafiteAst.Record (freshen_name_ty params, n, freshen_term ty,
- freshen_name_ty fields)
-
-let freshen_term = freshen_term ?index:None
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-val fresh_name: unit -> string
-
-val variables_of_term: CicNotationPt.term -> CicNotationPt.pattern_variable list
-val names_of_term: CicNotationPt.term -> string list
-
- (** extract all keywords (i.e. string literals) from a level 1 pattern *)
-val keywords_of_term: CicNotationPt.term -> string list
-
-val visit_ast:
- ?special_k:(CicNotationPt.term -> CicNotationPt.term) ->
- (CicNotationPt.term -> CicNotationPt.term) ->
- CicNotationPt.term ->
- CicNotationPt.term
-
-val visit_layout:
- (CicNotationPt.term -> CicNotationPt.term) ->
- CicNotationPt.layout_pattern ->
- CicNotationPt.layout_pattern
-
-val visit_magic:
- (CicNotationPt.term -> CicNotationPt.term) ->
- CicNotationPt.magic_term ->
- CicNotationPt.magic_term
-
-val visit_variable:
- (CicNotationPt.term -> CicNotationPt.term) ->
- CicNotationPt.pattern_variable ->
- CicNotationPt.pattern_variable
-
-val strip_attributes: CicNotationPt.term -> CicNotationPt.term
-
- (** @return the list of proper (i.e. non recursive) IdRef of a term *)
-val get_idrefs: CicNotationPt.term -> string list
-
- (** generalization of List.combine to n lists *)
-val ncombine: 'a list list -> 'a list list
-
-val string_of_literal: CicNotationPt.literal -> string
-
-val dress: sep:'a -> 'a list -> 'a list
-val dressn: sep:'a list -> 'a list -> 'a list
-
-val boxify: CicNotationPt.term list -> CicNotationPt.term
-val group: CicNotationPt.term list -> CicNotationPt.term
-val ungroup: CicNotationPt.term list -> CicNotationPt.term list
-
-val find_appl_pattern_uris:
- CicNotationPt.cic_appl_pattern -> UriManager.uri list
-
-val find_branch:
- CicNotationPt.term -> CicNotationPt.term
-
-val cic_name_of_name: CicNotationPt.term -> Cic.name
-val name_of_cic_name: Cic.name -> CicNotationPt.term
-
- (** Symbol/Numbers instances *)
-
-val freshen_term: CicNotationPt.term -> CicNotationPt.term
-val freshen_obj: GrafiteAst.obj -> GrafiteAst.obj
-
- (** Notation id handling *)
-
-type notation_id
-
-val fresh_id: unit -> notation_id
-
+++ /dev/null
-main.aux
-main.dvi
-main.log
-main.out
-main.pdf
-main.ps
+++ /dev/null
-
-#
-# Generic makefile for latex
-#
-# Author: Stefano Zacchiroli <zack@bononia.it>
-#
-# Created: Sun, 29 Jun 2003 12:00:55 +0200 zack
-# Last-Modified: Mon, 10 Oct 2005 15:37:12 +0200 zack
-#
-
-########################################################################
-
-# list of .tex _main_ files
-TEXS = main.tex
-
-# number of runs of latex (for table of contents, list of figures, ...)
-RUNS = 1
-
-# do you need bibtex?
-BIBTEX = no
-
-# would you like to use pdflatex?
-PDF_VIA_PDFLATEX = yes
-
-# which formats generated by default ("all" target)?
-# (others will be generated by "world" target)
-# see AVAILABLE_FORMATS below
-BUILD_FORMATS = dvi
-
-# which format to be shown on "make show"
-SHOW_FORMAT = dvi
-
-########################################################################
-
-AVAILABLE_FORMATS = dvi ps ps.gz pdf html
-
-ADVI = advi
-BIBTEX = bibtex
-BROWSER = galeon
-DVIPDF = dvipdf
-DVIPS = dvips
-GV = gv
-GZIP = gzip
-HEVEA = hevea
-ISPELL = ispell
-LATEX = latex
-PDFLATEX = pdflatex
-PRINT = lpr
-XDVI = xdvi
-XPDF = xpdf
-
-ALL_FORMATS = $(BUILD_FORMATS)
-WORLD_FORMATS = $(AVAILABLE_FORMATS)
-
-all: $(ALL_FORMATS)
-world: $(WORLD_FORMATS)
-
-DVIS = $(TEXS:.tex=.dvi)
-PSS = $(TEXS:.tex=.ps)
-PSGZS = $(TEXS:.tex=.ps.gz)
-PDFS = $(TEXS:.tex=.pdf)
-HTMLS = $(TEXS:.tex=.html)
-
-dvi: $(DVIS)
-ps: $(PSS)
-ps.gz: $(PSGZS)
-pdf: $(PDFS)
-html: $(HTMLS)
-
-show: show$(SHOW_FORMAT)
-showdvi: $(DVIS)
- $(XDVI) $<
-showps: $(PSS)
- $(GV) $<
-showpdf: $(PDFS)
- $(XPDF) $<
-showpsgz: $(PSGZS)
- $(GV) $<
-showps.gz: showpsgz
-showhtml: $(HTMLS)
- $(BROWSER) $<
-
-print: $(PSS)
- $(PRINT) $^
-
-clean:
- rm -f \
- $(TEXS:.tex=.dvi) $(TEXS:.tex=.ps) $(TEXS:.tex=.ps.gz) \
- $(TEXS:.tex=.pdf) $(TEXS:.tex=.aux) $(TEXS:.tex=.log) \
- $(TEXS:.tex=.html) $(TEXS:.tex=.out) $(TEXS:.tex=.haux) \
- $(TEXS:.tex=.htoc) $(TEXS:.tex=.tmp)
-
-%.dvi: %.tex
- $(LATEX) $<
- if [ "$(BIBTEX)" = "yes" ]; then $(BIBTEX) $*; fi
- if [ "$(RUNS)" -gt 1 ]; then \
- for i in seq 1 `expr $(RUNS) - 1`; do \
- $(LATEX) $<; \
- done; \
- fi
-ifeq ($(PDF_VIA_PDFLATEX),yes)
-%.pdf: %.tex
- $(PDFLATEX) $<
- if [ "$(BIBTEX)" = "yes" ]; then $(BIBTEX) $*; fi
- if [ "$(RUNS)" -gt 1 ]; then \
- for i in seq 1 `expr $(RUNS) - 1`; do \
- $(PDFLATEX) $<; \
- done; \
- fi
-else
-%.pdf: %.dvi
- $(DVIPDF) $< $@
-endif
-%.ps: %.dvi
- $(DVIPS) $<
-%.ps.gz: %.ps
- $(GZIP) -c $< > $@
-%.html: %.tex
- $(HEVEA) -fix $<
-
-.PHONY: all ps pdf html clean
-
-########################################################################
-
+++ /dev/null
-
-\section{Introduction}
-
-Mathematical notation plays a fundamental role in mathematical practice: it
-helps expressing in a concise symbolic fashion concepts of arbitrary complexity.
-Its use in proof assistants like \MATITA{} is no exception. Formal mathematics
-indeed often impose to encode mathematical concepts at a very high level of
-details (e.g. Peano numbers, implicit arguments) having a restricted toolbox of
-syntactic constructions in the calculus.
-
-Consider for example one of the point reached while proving the distributivity
-of times over minus on natural numbers included in the \MATITA{} standards
-library. (Part of) the reached sequent can be seen in \MATITA{} both using the
-notation for various arithmetical and relational operator or without using it.
-The sequent rendered without using notation looks as follows:
-
-\sequent{
-\mathtt{H}: \mathtt{le} z y\\
-\mathtt{Hcut}: \mathtt{eq} \mathtt{nat} (\mathtt{plus} (\mathtt{times} x (\mathtt{minus}
-y z)) (\mathtt{times} x z))\\
-(\mathtt{plus} (\mathtt{minus} (\mathtt{times} x y) (\mathtt{times} x z))
-(\mathtt{times} x z))}{
-\mathtt{eq} \mathtt{nat} (\mathtt{times} x (\mathtt{minus} y z)) (\mathtt{minus}
-(\mathtt{times} x y) (\mathtt{times} x z))}
-
-while the corresponding sequent rendered with notation enabled looks:
-
-\sequent{
-H: z\leq y\\
-Hcut: x*(y-z)+x*z=x*y-x*z+x*z}{
-x*(y-z)=x*y-x*z}
-
-The latter representation is evidently more readable than the former helping
-users both in concentrating on the key aspects of the proof (namely on choosing
-the right strategy to proceed in the proof) and in reducing the amount of input
-that need to be provided to the system when term input is required (assuming the
-exists a correspondence among the rendered output and the textual input syntax
-used by the user, as it happens in \MATITA).
-
-In this section we present the \emph{extensible notation} mechanism implemented
-in \MATITA. Its role may be looked at from two different point of view: the term
-input phase and the term output --- or rendering --- phase. We arbitrarly
-decided to call the former view ``from the left'' and the latter ``from the
-right''. Looking from the point of view of the input phase it offers a mechanism
-of dynamic extension of the term grammar enabling the user to define fancy
-mathematical notations. Looking from the point of view of rendering it enable
-the reconstruction of such notations from CIC term and its rendering to various
-presentation languages (at the time of writing supported languages are MathML
-Presentation and the \MATITA{} concrete syntax for terms).
-
-If you're wondering why the notation mechanisms need to be ``extensible'', the
-answer lays in how notation is used in the development of formal mathematics
-with proof assistants. When doing ordinary (i.e. non automatically checkable by
-the mean of a proof checker) mathematics, notation is often confused with the
-mathematical objects being defined. ``+'' may be thought as \emph{the} addition
-(and is often termed as such in mathematical textbooks!), but is rather the
-notation for one particolar kind of addition which may possibly be used in an
-overloaded fashion elsewhere. When doing formal mathematics the difference is
-tangible and users has to deal separately with all the actions we skimmed
-through:
-
-\begin{enumerate}
-
- \item definition of mathematical objects (e.g. addition over Peano numbers
- using the primitive recursion scheme);
-
- \item definition of new mathematical notation (e.g. infix use of the $+$ symbol
- as in $x + 3$);
-
- \item (incremental) definition of the meanings of a given notation (e.g. the
- use of the notation of (2) above for denoting the addition of (1)).
-
-\end{enumerate}
-
-Since all the points above are part of everyday life of proof assistants users
-we know that mathematical notation in the system will change and we can't
-provide a ``one-size fits all'' solution as is done for instance in mainstream
-programming languages mathematical notation. For this reason \MATITA{} supports
-all the above actions in a coherent manner in both term input and output.
-
-\section{Looking from the left: term input}
-
-\subsubsection{\MATITA{} input phase}
-
- \begin{table}
- \caption{\label{tab:termsyn} Concrete syntax of CIC terms: built-in
- notation\strut}
- \hrule
- \[
- \begin{array}{@{}rcll@{}}
- \NT{term} & ::= & & \mbox{\bf terms} \\
- & & x & \mbox{(identifier)} \\
- & | & n & \mbox{(number)} \\
- & | & s & \mbox{(symbol)} \\
- & | & \mathrm{URI} & \mbox{(URI)} \\
- & | & \verb+_+ & \mbox{(implicit)} \\
- & | & \verb+?+n~[\verb+[+~\{\NT{subst}\}~\verb+]+] & \mbox{(meta)} \\
- & | & \verb+let+~\NT{ptname}~\verb+\def+~\NT{term}~\verb+in+~\NT{term} \\
- & | & \verb+let+~\NT{kind}~\NT{defs}~\verb+in+~\NT{term} \\
- & | & \NT{binder}~\{\NT{ptnames}\}^{+}~\verb+.+~\NT{term} \\
- & | & \NT{term}~\NT{term} & \mbox{(application)} \\
- & | & \verb+Prop+ \mid \verb+Set+ \mid \verb+Type+ \mid \verb+CProp+ & \mbox{(sort)} \\
- & | & \verb+match+~\NT{term}~ & \mbox{(pattern matching)} \\
- & & ~ ~ [\verb+[+~\verb+in+~x~\verb+]+]
- ~ [\verb+[+~\verb+return+~\NT{term}~\verb+]+] \\
- & & ~ ~ \verb+with [+~[\NT{rule}~\{\verb+|+~\NT{rule}\}]~\verb+]+ & \\
- & | & \verb+(+~\NT{term}~\verb+:+~\NT{term}~\verb+)+ & \mbox{(cast)} \\
- & | & \verb+(+~\NT{term}~\verb+)+ \\
- \NT{defs} & ::= & & \mbox{\bf mutual definitions} \\
- & & \NT{fun}~\{\verb+and+~\NT{fun}\} \\
- \NT{fun} & ::= & & \mbox{\bf functions} \\
- & & \NT{arg}~\{\NT{ptnames}\}^{+}~[\verb+on+~x]~\verb+\def+~\NT{term} \\
- \NT{binder} & ::= & & \mbox{\bf binders} \\
- & & \verb+\forall+ \mid \verb+\lambda+ \\
- \NT{arg} & ::= & & \mbox{\bf single argument} \\
- & & \verb+_+ \mid x \\
- \NT{ptname} & ::= & & \mbox{\bf possibly typed name} \\
- & & \NT{arg} \\
- & | & \verb+(+~\NT{arg}~\verb+:+~\NT{term}~\verb+)+ \\
- \NT{ptnames} & ::= & & \mbox{\bf bound variables} \\
- & & \NT{arg} \\
- & | & \verb+(+~\NT{arg}~\{\verb+,+~\NT{arg}\}~[\verb+:+~\NT{term}]~\verb+)+ \\
- \NT{kind} & ::= & & \mbox{\bf induction kind} \\
- & & \verb+rec+ \mid \verb+corec+ \\
- \NT{rule} & ::= & & \mbox{\bf rules} \\
- & & x~\{\NT{ptname}\}~\verb+\Rightarrow+~\NT{term}
- \end{array}
- \]
- \hrule
- \end{table}
-
-The primary form of user interaction employed by \MATITA{} is textual script
-editing: the user modifies it and evaluate step by step its composing
-\emph{statements}. Examples of statements are inductive type definitions,
-theorem declarations, LCF-style tacticals, and macros (e.g. \texttt{Check} can
-be used to ask the system to refine a given term and pretty print the result).
-Since many statements refer to terms of the underlying calculus, \MATITA{} needs
-a concrete syntax able to encode terms of the Calculus of Inductive
-Constructions.
-
-Two of the requirements in the design of such a syntax are apparently in
-contrast:
-
-\begin{enumerate}
-
- \item the syntax should be as close as possible to common mathematical practice
- and implement widespread mathematical notations;
-
- \item each term described by the syntax should be non-ambiguous meaning that it
- should exists a function which associates to it a CIC term.
-
-\end{enumerate}
-
-These two requirements are addressed in \MATITA{} by the mean of two mechanisms
-which work together: \emph{term disambiguation} and \emph{extensible notation}.
-Their interaction is visible in the architecture of the \MATITA{} input phase,
-depicted in Fig.~\ref{fig:inputphase}. The architecture is articulated as a
-pipeline of three levels: the concrete syntax level (level 0) is the one the
-user has to deal with when inserting CIC terms; the abstract syntax level (level
-2) is an internal representation which intuitively encodes mathematical formulae
-at the content level~\cite{adams}\cite{mkm-structure}; the last level is that of
-CIC terms.
-
-\begin{figure}[ht]
- \begin{center}
- \includegraphics[width=0.9\textwidth]{input_phase}
- \caption{\MATITA{} input phase}
- \end{center}
- \label{fig:inputphase}
-\end{figure}
-
-Requirement (1) is addressed by a built-in concrete syntax for terms, described
-in Tab.~\ref{tab:termsyn}, and the extensible notation mechanisms which offers a
-way for extending available mathematical notations and providing a parser for
-the extended notation. Requirement (2) is addressed by the conjunct action of
-that parsing function and disambiguation which provides a function from content
-level terms to CIC terms.
-
-\subsubsection{From concrete syntax to content level}
-
-Content level terms are instances of what are commonly referred as Abstract
-Syntax Trees (ASTs) in compilers literature. In this respect the mapping from
-concrete syntax fo content level is nothing more than the pipelined application
-of a lexer and a parser to the characters that form terms at the concrete syntax
-level.
-
-The plus offered by the notation mechanisms is the ability to dinamically extend
-the parsing rules which build abstract syntax tree from stream of lexer tokens.
-For example, in the standard library of \MATITA{} we found the following
-statements which define the notation used for the ``+'' infix operator.
-
-\begin{example}
-\begin{Verbatim}
- notation "a + b"
- left associative with precedence 50
- for @{ 'plus $a $b }.
-\end{Verbatim}
-\end{example}
-
-The meaning of such a statement is to declare a bidirectional
-mapping\footnote{in this section we only deal with the left to right part of the
-mapping, but it is actually bidirectional} between a concrete syntax pattern
-(the part of the statement inside double quotes) and a content level pattern
-(the part of the statement which follows \texttt{for}). The syntax of concrete
-syntax patterns and content level patterns can be found in Tab.~\ref{tab:l1c}
-and Tab.~\ref{tab:l2c} respectively.
-
-\begin{table}
-\caption{\label{tab:l1c} Concrete syntax of level 1 patterns.\strut}
-\hrule
-\[
-\begin{array}{rcll}
- P & ::= & & \mbox{(\bf patterns)} \\
- & & S^{+} \\[2ex]
- S & ::= & & \mbox{(\bf simple patterns)} \\
- & & l \\
- & | & S~\verb+\sub+~S\\
- & | & S~\verb+\sup+~S\\
- & | & S~\verb+\below+~S\\
- & | & S~\verb+\atop+~S\\
- & | & S~\verb+\over+~S\\
- & | & S~\verb+\atop+~S\\
- & | & \verb+\frac+~S~S \\
- & | & \verb+\sqrt+~S \\
- & | & \verb+\root+~S~\verb+\of+~S \\
- & | & \verb+(+~P~\verb+)+ \\
- & | & \verb+hbox (+~P~\verb+)+ \\
- & | & \verb+vbox (+~P~\verb+)+ \\
- & | & \verb+hvbox (+~P~\verb+)+ \\
- & | & \verb+hovbox (+~P~\verb+)+ \\
- & | & \verb+break+ \\
- & | & \verb+list0+~S~[\verb+sep+~l] \\
- & | & \verb+list1+~S~[\verb+sep+~l] \\
- & | & \verb+opt+~S \\
- & | & [\verb+term+]~x \\
- & | & \verb+number+~x \\
- & | & \verb+ident+~x \\
-\end{array}
-\]
-\hrule
-\end{table}
-
-\begin{table}
-\caption{\label{tab:l1a} Abstract syntax of level 1 terms and patterns.\strut}
-\hrule
-\[
-\begin{array}{@{}ll@{}}
-\begin{array}[t]{rcll}
- T & ::= & & \mbox{(\bf terms)} \\
- & & L_\kappa[T_1,\dots,T_n] & \mbox{(layout)} \\
- & | & B_\kappa^{ab}[T_1\cdots T_n] & \mbox{(box)} \\
- & | & \BREAK & \mbox{(breakpoint)} \\
- & | & \FENCED{T_1\cdots T_n} & \mbox{(fenced)} \\
- & | & l & \mbox{(literal)} \\[2ex]
- P & ::= & & \mbox{(\bf patterns)} \\
- & & L_\kappa[P_1,\dots,P_n] & \mbox{(layout)} \\
- & | & B_\kappa^{ab}[P_1\cdots P_n] & \mbox{(box)} \\
- & | & \BREAK & \mbox{(breakpoint)} \\
- & | & \FENCED{P_1\cdots P_n} & \mbox{(fenced)} \\
- & | & M & \mbox{(magic)} \\
- & | & V & \mbox{(variable)} \\
- & | & l & \mbox{(literal)} \\
-\end{array} &
-\begin{array}[t]{rcll}
- V & ::= & & \mbox{(\bf variables)} \\
- & & \TVAR{x} & \mbox{(term variable)} \\
- & | & \NVAR{x} & \mbox{(number variable)} \\
- & | & \IVAR{x} & \mbox{(name variable)} \\[2ex]
- M & ::= & & \mbox{(\bf magic patterns)} \\
- & & \verb+list0+~P~l? & \mbox{(possibly empty list)} \\
- & | & \verb+list1+~P~l? & \mbox{(non-empty list)} \\
- & | & \verb+opt+~P & \mbox{(option)} \\[2ex]
-\end{array}
-\end{array}
-\]
-\hrule
-\end{table}
-
-\begin{table}
-\caption{\label{tab:synl2} Concrete syntax of level 2 patterns.\strut}
-\hrule
-\[
-\begin{array}{@{}rcll@{}}
- \NT{term} & ::= & & \mbox{\bf terms} \\
- & & x & \mbox{(identifier)} \\
- & | & n & \mbox{(number)} \\
- & | & s & \mbox{(symbol)} \\
- & | & \mathrm{URI} & \mbox{(URI)} \\
- & | & \verb+?+ & \mbox{(implicit)} \\
- & | & \verb+%+ & \mbox{(placeholder)} \\
- & | & \verb+?+n~[\verb+[+~\{\NT{subst}\}~\verb+]+] & \mbox{(meta)} \\
- & | & \verb+let+~\NT{ptname}~\verb+\def+~\NT{term}~\verb+in+~\NT{term} \\
- & | & \verb+let+~\NT{kind}~\NT{defs}~\verb+in+~\NT{term} \\
- & | & \NT{binder}~\{\NT{ptnames}\}^{+}~\verb+.+~\NT{term} \\
- & | & \NT{term}~\NT{term} & \mbox{(application)} \\
- & | & \verb+Prop+ \mid \verb+Set+ \mid \verb+Type+ \mid \verb+CProp+ & \mbox{(sort)} \\
- & | & [\verb+[+~\NT{term}~\verb+]+]~\verb+match+~\NT{term}~\verb+with [+~[\NT{rule}~\{\verb+|+~\NT{rule}\}]~\verb+]+ & \mbox{(pattern match)} \\
- & | & \verb+(+~\NT{term}~\verb+:+~\NT{term}~\verb+)+ & \mbox{(cast)} \\
- & | & \verb+(+~\NT{term}~\verb+)+ \\
- & | & \BLOB(\NT{meta},\dots,\NT{meta}) & \mbox{(meta blob)} \\
- \NT{defs} & ::= & & \mbox{\bf mutual definitions} \\
- & & \NT{fun}~\{\verb+and+~\NT{fun}\} \\
- \NT{fun} & ::= & & \mbox{\bf functions} \\
- & & \NT{arg}~\{\NT{ptnames}\}^{+}~[\verb+on+~x]~\verb+\def+~\NT{term} \\
- \NT{binder} & ::= & & \mbox{\bf binders} \\
- & & \verb+\Pi+ \mid \verb+\exists+ \mid \verb+\forall+ \mid \verb+\lambda+ \\
- \NT{arg} & ::= & & \mbox{\bf single argument} \\
- & & \verb+_+ \mid x \mid \BLOB(\NT{meta},\dots,\NT{meta}) \\
- \NT{ptname} & ::= & & \mbox{\bf possibly typed name} \\
- & & \NT{arg} \\
- & | & \verb+(+~\NT{arg}~\verb+:+~\NT{term}~\verb+)+ \\
- \NT{ptnames} & ::= & & \mbox{\bf bound variables} \\
- & & \NT{arg} \\
- & | & \verb+(+~\NT{arg}~\{\verb+,+~\NT{arg}\}~[\verb+:+~\NT{term}]~\verb+)+ \\
- \NT{kind} & ::= & & \mbox{\bf induction kind} \\
- & & \verb+rec+ \mid \verb+corec+ \\
- \NT{rule} & ::= & & \mbox{\bf rules} \\
- & & x~\{\NT{ptname}\}~\verb+\Rightarrow+~\NT{term} \\[10ex]
-
- \NT{meta} & ::= & & \mbox{\bf meta} \\
- & & \BLOB(\NT{term},\dots,\NT{term}) & \mbox{(term blob)} \\
- & | & [\verb+term+]~x \\
- & | & \verb+number+~x \\
- & | & \verb+ident+~x \\
- & | & \verb+fresh+~x \\
- & | & \verb+anonymous+ \\
- & | & \verb+fold+~[\verb+left+\mid\verb+right+]~\NT{meta}~\verb+rec+~x~\NT{meta} \\
- & | & \verb+default+~\NT{meta}~\NT{meta} \\
- & | & \verb+if+~\NT{meta}~\verb+then+~\NT{meta}~\verb+else+~\NT{meta} \\
- & | & \verb+fail+
-\end{array}
-\]
-\hrule
-\end{table}
-
-Each time a \texttt{notation} statement is evaluated by \MATITA{} a new parsing
-rule, extracted from the concrete syntax pattern, is added to the term parser
-and a semantic action which build a content level term, extracted from the
-content level pattern, is associated to it. We will now describe in turn what
-can be part of a concrete syntax pattern and what can be part of a content level
-pattern.
-
-Concrete syntax patterns, whose abstract syntax can additionally be found in
-Tab.~\ref{tab:l1a} can be made of several components. The most basic of which
-are \emph{literal symbols} (like the ``+'' in the example above) and \emph{term
-variables} (like ``a'' and ``b''). During the extraction of parsing rules
-literal symbols are mapped to productions expecting those symbols verbatim as
-input and term variables as production expecting other terms (instances of the
-same parsing rule we are extending, possibly with different precedence and/or
-associativity).
-
-\ldots
-
-\subsubsection{From content level to CIC}
-
-Responsible of mapping content level terms to CIC terms is the disambiguation
-algorithm implemented in \MATITA. Since it has already been described
-elsewhere~\cite{disambiguation} we wont enter in too much details here. We only
-give some highlights of its fundamental concepts.
-
-\subsubsection{Sources of ambiguity}
-
-The translation from content level terms to CIC terms is not straightforward
-because some nodes of the content encoding admit more that one CIC encoding,
-invalidating requirement (2).
-
-\begin{example}
- \label{ex:disambiguation}
-
- Consider the term at the concrete syntax level \texttt{\TEXMACRO{forall} x. x +
- ln 1 = x} of Fig.~\ref{fig:inputphase}(a), it can be the type of a lemma the
- user may want to prove. Assuming that both \texttt{+} and \texttt{=} are parsed
- as infix operators, all the following questions are legitimate and must be
- answered before obtaining a CIC term from its content level encoding
- (Fig.~\ref{fig:inputphase}(b)):
-
- \begin{enumerate}
-
- \item Since \texttt{ln} is an unbound identifier, which CIC constants does it
- represent? Many different theorems in the library may share its (rather
- short) name \dots
-
- \item Which kind of number (\IN, \IR, \dots) the \texttt{1} literal stand for?
- Which encoding is used in CIC to represent it? E.g., assuming $1\in\IN$, is
- it an unary or a binary encoding?
-
- \item Which kind of equality the ``='' node represents? Is it Leibniz's
- polymorhpic equality? Is it a decidable equality over \IN, \IR, \dots?
-
- \end{enumerate}
-
-\end{example}
-
-In \MATITA, three \emph{sources of ambiguity} are admitted for content level
-terms: unbound identifiers, literal numbers, and operators. Each instance of
-ambiguity sources (ambiguous entity) occuring in a content level term is
-associated to a \emph{disambiguation domain}. Intuitively a disambiguation
-domain is a set of CIC terms which may be replaced for an ambiguous entity
-during disambiguation. Each item of the domain is said to be an
-\emph{interpretation} for the ambiguous entity.
-
-\emph{Unbound identifiers} (question 1) are ambiguous entities since the
-namespace of CIC objects is not flat and the same identifier may denote many
-ofthem. For example the short name \texttt{plus\_assoc} in the \HELM{} library
-is shared by three different theorems stating the associative property of
-different additions. This kind of ambiguity is avoidable if the user is willing
-to use long names (in form of URIs in the \texttt{cic://} scheme) in the
-concrete syntax, with the obvious drawbacks of obtaining long and unreadable
-terms.
-
-Given an unbound identifier, the corresponding disambiguation domain is computed
-querying the library for all constants, inductive types, and inductive type
-constructors having it as their short name (see the \LOCATE{} query in
-Sect.~\ref{sec:metadata}).
-
-\emph{Literal numbers} (question 2) are ambiguous entities as well since
-different kinds of numbers can be encoded in CIC (\IN, \IR, \IZ, \dots) using
-different encodings. Considering the restricted example of natural numbers we
-can for instance encode them in CIC using inductive datatypes with a number of
-constructor equal to the encoding base plus 1, obtaining one encoding for each
-base.
-
-For each possible way of mapping a literal number to a CIC term, \MATITA{} is
-aware of a \emph{number intepretation function} which, when applied to the
-natural number denoted by the literal\footnote{at the moment only literal
-natural number are supported in the concrete syntax} returns a corresponding CIC
-term. The disambiguation domain for a given literal number is built applying to
-the literal all available number interpretation functions in turn.
-
-Number interpretation functions can at the moment only be defined in OCaml, but
-a mechanism to enable their definition directly in \MATITA{} is under
-developement.
-
-\emph{Operators} (question 3) are intuitively head of applications, as such they
-are always applied to a (possiblt empty) sequence of arguments. Their ambiguity
-is a need since it is often the case that some notation is used in an overloaded
-fashion to hide the use of different CIC constants which encodes similar
-concepts. For example, in the standard library of \MATITA{} the infix \texttt{+}
-notation is available building a binary \texttt{Op(+)} node, whose
-disambiguation domain may refer to different constants like the addition over
-natural numbers \URI{cic:/matita/nat/plus/plus.con} or that over real numbers of
-the \COQ{} standard library \URI{cic:/Coq/Reals/Rdefinitions/Rplus.con}.
-
-For each possible way of mapping an operator application to a CIC term,
-\MATITA{} knows an \emph{operator interpretation function} which, when applied
-to an operator and its arguments, returns a CIC term. The disambiguation domain
-for a given operator is built applying to the operator and its arguments all
-available operator interpretation functions in turn.
-
-Operator interpretation functions could be added using the
-\texttt{interpretation} statement. For example, among the first line of the
-script \texttt{matita/library/logic/equality.ma} from the \MATITA{} standard
-library we read:
-
-\begin{Verbatim}
-interpretation "leibnitz's equality"
- 'eq x y =
- (cic:/matita/logic/equality/eq.ind#xpointer(1/1) _ x y).
-\end{Verbatim}
-
-Evaluating it in \MATITA{} will add an operator interpretation function for the
-binary operator \texttt{eq} which expands to the CIC term on the right hand side
-of the statement. That CIC term can be written using only built-in concrete
-syntax, can contain no ambiguity source; still, it can refer to operator
-arguments bound on the left hand side and can contain implicit terms (denoted
-with \texttt{\_}) which will be expanded to fresh metavariables. The latter
-feature is used in the example above for the first argument of Leibniz's
-polymorhpic equality.
-
-\subsubsection{Disambiguation algorithm}
-
-A \emph{disambiguation algorithm} takes as input a content level term and return
-a fully determined CIC term. The key observation on which a disambiguation
-algorithm is based is that given a content level term with more than one sources
-of ambiguity, not all possible combination of interpretation lead to a typable
-CIC term. In the term of Ex.~\ref{ex:disambiguation} for instance the
-interpretation of \texttt{ln} as a function from \IR to \IR and the
-interpretation of \texttt{1} as the Peano number $1$ can't coexists. The notion
-of ``can't coexists'' in the disambiguation of \MATITA{} is defined on top of
-the \emph{refiner} for CIC terms described in~\cite{csc-phd}.
-
-Briefly, a refiner is a function whose input is an \emph{incomplete CIC term}
-$t_1$ --- i.e. a term where metavariables occur (Sect.~\ref{sec:metavariables}
---- and whose output is either
-
-\begin{enumerate}
-
- \item an incomplete CIC term $t_2$ where $t_2$ is a well-typed term obtained
- assigning a type to each metavariable in $t_1$ (in case of dependent types,
- instantiation of some of the metavariable occurring in $t_1$ may occur as
- well);
-
- \item $\epsilon$, meaning that no well-typed term could be obtained via
- assignment of type to metavariable in $t_1$ and their instantiation;
-
- \item $\bot$, meaning that the refiner is unable to decide whether of the two
- cases above apply (refinement is semi-decidable).
-
-\end{enumerate}
-
-On top of a CIC refiner \MATITA{} implement an efficient disambiguation
-algorithm, which is outlined below. It takes as input a content level term $c$
-and proceeds as follows:
-
-\begin{enumerate}
-
- \item Create disambiguation domains $\{D_i | i\in\mathit{Dom}(c)\}$, where
- $\mathit{Dom}(c)$ is the set of ambiguity sources of $c$. Each $D_i$ is a set
- of CIC terms and can be built as described above.
-
- \item An \emph{interpretation} $\Phi$ for $c$ is a map associating an
- incomplete CIC term to each ambiguity source of $c$. Given $c$ and one of its
- interpretations an incomplete CIC term is fully determined replacing each
- ambiguity source of $c$ with its mapping in the interpretation and injecting
- the remaining structure of the content level in the CIC level (e.g. replacing
- the application of the content level with the application of the CIC level).
- This operation is informally called ``interpreting $c$ with $\Phi$''.
-
- Create an initial interpretation $\Phi_0 = \{\phi_i | \phi_i = \_,
- i\in\mathit{Dom}(c)\}$, which associates a fresh metavariable to each source
- of ambiguity of $c$. During this step, implicit terms are expanded to fresh
- metavariables as well.
-
- \item Refine the current incomplete CIC term (i.e. the term obtained
- interpreting $t$ with $\Phi_i$).
-
- If the refinement succeeds or is undetermined the next interpretation
- $\Phi_{i+1}$ will be created \emph{making a choice}, that is replacing in the
- current interpretation one of the metavariable appearing in $\Phi_i$ with one
- of the possible choice from the corresponding disambiguation domain. The
- metavariable to be replaced is chosen following a preorder visit of the
- ambiguous term. Then, step 3 is attempted again with the new interpretation.
-
- If the refinement fails the current set of choices cannot lead to a well-typed
- term and backtracking of the current interpretation is attempted.
-
- \item Once an unambiguous correct interpretation is found (i.e. $\Phi_i$ does
- no longer contain any placeholder), backtracking is attempted anyway to find
- the other correct interpretations.
-
- \item Let $n$ be the number of interpretations who survived step 4. If $n=0$
- signal a type error. If $n=1$ we have found exactly one (incomplete) CIC term
- corresponding to the content level term $c$, returns it as output of the
- disambiguation phase. If $n>1$ we have found many different (incomplete) CIC
- terms which can correspond to the content level term, let the user choose one
- of the $n$ interpretations and returns the corresponding term.
-
-\end{enumerate}
-
-The efficiency of this algorithm resides in the fact that as soon as an
-incomplete CIC term is not typable, no further instantiation of the
-metavariables of the corresponding interpretation is attemped.
-% For example, during the disambiguation of the user input
-% \texttt{\TEXMACRO{forall} x. x*0 = 0}, an interpretation $\Phi_i$ is
-% encountered which associates $?$ to the instance of \texttt{0} on the right,
-% the real number $0$ to the instance of \texttt{0} on the left, and the
-% multiplication over natural numbers (\texttt{mult} for short) to \texttt{*}.
-% The refiner will fail, since \texttt{mult} require a natural argument, and no
-% further instantiation of the placeholder will be tried.
-
-Details of the disambiguation algorithm along with an analysis of its complexity
-can be found in~\cite{disambiguation}, where a formulation without backtracking
-(corresponding to the actual \MATITA{} implementation) is also presented.
-
-\subsubsection{Disambiguation stages}
-
-\section{Environment}
-
-\[
-\begin{array}{rcll}
- V & ::= & & \mbox{(\bf values)} \\
- & & \verb+Term+~T & \mbox{(term)} \\
- & | & \verb+String+~s & \mbox{(string)} \\
- & | & \verb+Number+~n & \mbox{(number)} \\
- & | & \verb+None+ & \mbox{(optional value)} \\
- & | & \verb+Some+~V & \mbox{(optional value)} \\
- & | & [V_1,\dots,V_n] & \mbox{(list value)} \\[2ex]
-\end{array}
-\]
-
-An environment is a map $\mathcal E : \mathit{Name} -> V$.
-
-\section{Level 1: concrete syntax}
-
-Rationale: while the layout schemata can occur in the concrete syntax
-used by user, the box schemata and the magic patterns can only occur
-when defining the notation. This is why the layout schemata are
-``escaped'' with a backslash, so that they cannot be confused with
-plain identifiers, wherease the others are not. Alternatively, they
-could be defined as keywords, but this would prevent their names to be
-used in different contexts.
-
-\[
-\ITO{\cdot}{{}} : P -> \mathit{Env} -> T
-\]
-
-\begin{table}
-\caption{\label{tab:il1f2} Instantiation of level 1 patterns from level 2.\strut}
-\hrule
-\[
-\begin{array}{rcll}
- \ITO{L_\kappa[P_1,\dots,P_n]}{E} & = & L_\kappa[\ITO{(P_1)}{E},\dots,\ITO{(P_n)}{E} ] \\
- \ITO{B_\kappa^{ab}[P_1\cdots P_n]}{E} & = & B_\kappa^{ab}[\ITO{P_1}{E}\cdots\ITO{P_n}{E}] \\
- \ITO{\BREAK}{E} & = & \BREAK \\
- \ITO{(P)}{E} & = & \ITO{P}{E} \\
- \ITO{(P_1\cdots P_n)}{E} & = & B_H^{00}[\ITO{P_1}{E}\cdots\ITO{P_n}{E}] \\
- \ITO{\TVAR{x}}{E} & = & t & \mathcal{E}(x) = \verb+Term+~t \\
- \ITO{\NVAR{x}}{E} & = & l & \mathcal{E}(x) = \verb+Number+~l \\
- \ITO{\IVAR{x}}{E} & = & l & \mathcal{E}(x) = \verb+String+~l \\
- \ITO{\mathtt{opt}~P}{E} & = & \varepsilon & \mathcal{E}(\NAMES(P)) = \{\mathtt{None}\} \\
- \ITO{\mathtt{opt}~P}{E} & = & \ITO{P}{E'} & \mathcal{E}(\NAMES(P)) = \{\mathtt{Some}~v_1,\dots,\mathtt{Some}~v_n\} \\
- & & & \mathcal{E}'(x)=\left\{
- \begin{array}{@{}ll}
- v, & \mathcal{E}(x) = \mathtt{Some}~v \\
- \mathcal{E}(x), & \mbox{otherwise}
- \end{array}
- \right. \\
- \ITO{\mathtt{list}k~P~l?}{E} & = & \ITO{P}{{E}_1}~{l?}\cdots {l?}~\ITO{P}{{E}_n} &
- \mathcal{E}(\NAMES(P)) = \{[v_{11},\dots,v_{1n}],\dots,[v_{m1},\dots,v_{mn}]\} \\
- & & & n\ge k \\
- & & & \mathcal{E}_i(x) = \left\{
- \begin{array}{@{}ll}
- v_i, & \mathcal{E}(x) = [v_1,\dots,v_n] \\
- \mathcal{E}(x), & \mbox{otherwise}
- \end{array}
- \right. \\
- \ITO{l}{E} & = & l \\
-
-%% & | & (P) & \mbox{(fenced)} \\
-%% & | & M & \mbox{(magic)} \\
-%% & | & V & \mbox{(variable)} \\
-%% & | & l & \mbox{(literal)} \\[2ex]
-%% V & ::= & & \mbox{(\bf variables)} \\
-%% & & \TVAR{x} & \mbox{(term variable)} \\
-%% & | & \NVAR{x} & \mbox{(number variable)} \\
-%% & | & \IVAR{x} & \mbox{(name variable)} \\[2ex]
-%% M & ::= & & \mbox{(\bf magic patterns)} \\
-%% & & \verb+list0+~S~l? & \mbox{(possibly empty list)} \\
-%% & | & \verb+list1+~S~l? & \mbox{(non-empty list)} \\
-%% & | & \verb+opt+~S & \mbox{(option)} \\[2ex]
-\end{array}
-\]
-\hrule
-\end{table}
-
-\begin{table}
-\caption{\label{tab:wfl0} Well-formedness rules for level 1 patterns.\strut}
-\hrule
-\[
-\renewcommand{\arraystretch}{3.5}
-\begin{array}[t]{@{}c@{}}
- \inference[\sc layout]
- {P_i :: D_i & \forall i,j, i\ne j => \DOMAIN(D_i) \cap \DOMAIN(D_j) = \emptyset}
- {L_\kappa[P_1,\dots,P_n] :: D_1\oplus\cdots\oplus D_n}
- \\
- \inference[\sc box]
- {P_i :: D_i & \forall i,j, i\ne j => \DOMAIN(D_i) \cap \DOMAIN(D_j) = \emptyset}
- {B_\kappa^{ab}[P_1\cdots P_n] :: D_1\oplus\cdots\oplus D_n}
- \\
- \inference[\sc fenced]
- {P_i :: D_i & \forall i,j, i\ne j => \DOMAIN(D_i) \cap \DOMAIN(D_j) = \emptyset}
- {\FENCED{P_1\cdots P_n} :: D_1\oplus\cdots\oplus D_n}
- \\
- \inference[\sc breakpoint]
- {}
- {\BREAK :: \emptyset}
- \qquad
- \inference[\sc literal]
- {}
- {l :: \emptyset}
- \qquad
- \inference[\sc tvar]
- {}
- {\TVAR{x} :: \TVAR{x}}
- \\
- \inference[\sc nvar]
- {}
- {\NVAR{x} :: \NVAR{x}}
- \qquad
- \inference[\sc ivar]
- {}
- {\IVAR{x} :: \IVAR{x}}
- \\
- \inference[\sc list0]
- {P :: D & \forall x\in\DOMAIN(D), D'(x) = D(x)~\mathtt{List}}
- {\mathtt{list0}~P~l? :: D'}
- \\
- \inference[\sc list1]
- {P :: D & \forall x\in\DOMAIN(D), D'(x) = D(x)~\mathtt{List}}
- {\mathtt{list1}~P~l? :: D'}
- \\
- \inference[\sc opt]
- {P :: D & \forall x\in\DOMAIN(D), D'(x) = D(x)~\mathtt{Option}}
- {\mathtt{opt}~P :: D'}
-\end{array}
-\]
-\hrule
-\end{table}
-
-\newcommand{\ATTRS}[1]{\langle#1\rangle}
-\newcommand{\ANNPOS}[2]{\mathit{pos}(#1)_{#2}}
-
-\begin{table}
-\caption{\label{tab:addparens} Can't read the AST and need parentheses? Here you go!.\strut}
-\hrule
-\[
-\begin{array}{rcll}
- \ADDPARENS{l}{n} & = & l \\
- \ADDPARENS{\BREAK}{n} & = & \BREAK \\
- \ADDPARENS{\ATTRS{\mathit{prec}=m}T}{n} & = & \ADDPARENS{T}{m} & n < m \\
- \ADDPARENS{\ATTRS{\mathit{prec}=m}T}{n} & = & \FENCED{\ADDPARENS{T}{\bot}} & n > m \\
- \ADDPARENS{\ATTRS{\mathit{prec}=n,\mathit{assoc}=L,\mathit{pos}=R}T}{n} & = & \FENCED{\ADDPARENS{T}{\bot}} \\
- \ADDPARENS{\ATTRS{\mathit{prec}=n,\mathit{assoc}=R,\mathit{pos}=L}T}{n} & = & \FENCED{\ADDPARENS{T}{\bot}} \\
- \ADDPARENS{\ATTRS{\cdots}T}{n} & = & \ADDPARENS{T}{n} \\
- \ADDPARENS{L_\kappa[T_1,\dots,\underline{T_k},\dots,T_m]}{n} & = & L_\kappa[\ADDPARENS{T_1}{n},\dots,\ADDPARENS{T_k}{\bot},\dots,\ADDPARENS{T_m}{n}] \\
- \ADDPARENS{B_\kappa^{ab}[T_1,\dots,T_m]}{n} & = & B_\kappa^{ab}[\ADDPARENS{T_1}{n},\dots,\ADDPARENS{T_m}{n}]
-\end{array}
-\]
-\hrule
-\end{table}
-
-\begin{table}
-\caption{\label{tab:annpos} Annotation of level 1 meta variable with position information.\strut}
-\hrule
-\[
-\begin{array}{rcll}
- \ANNPOS{l}{p,q} & = & l \\
- \ANNPOS{\BREAK}{p,q} & = & \BREAK \\
- \ANNPOS{x}{1,0} & = & \ATTRS{\mathit{pos}=L}{x} \\
- \ANNPOS{x}{0,1} & = & \ATTRS{\mathit{pos}=R}{x} \\
- \ANNPOS{x}{p,q} & = & \ATTRS{\mathit{pos}=I}{x} \\
- \ANNPOS{B_\kappa^{ab}[P]}{p,q} & = & B_\kappa^{ab}[\ANNPOS{P}{p,q}] \\
- \ANNPOS{B_\kappa^{ab}[\{\BREAK\} P_1\cdots P_n\{\BREAK\}]}{p,q} & = & B_\kappa^{ab}[\begin{array}[t]{@{}l}
- \{\BREAK\} \ANNPOS{P_1}{p,0} \\
- \ANNPOS{P_2}{0,0}\cdots\ANNPOS{P_{n-1}}{0,0} \\
- \ANNPOS{P_n}{0,q}\{\BREAK\}]
- \end{array}
-
-%% & & L_\kappa[P_1,\dots,P_n] & \mbox{(layout)} \\
-%% & | & \BREAK & \mbox{(breakpoint)} \\
-%% & | & \FENCED{P_1\cdots P_n} & \mbox{(fenced)} \\
-%% V & ::= & & \mbox{(\bf variables)} \\
-%% & & \TVAR{x} & \mbox{(term variable)} \\
-%% & | & \NVAR{x} & \mbox{(number variable)} \\
-%% & | & \IVAR{x} & \mbox{(name variable)} \\[2ex]
-%% M & ::= & & \mbox{(\bf magic patterns)} \\
-%% & & \verb+list0+~P~l? & \mbox{(possibly empty list)} \\
-%% & | & \verb+list1+~P~l? & \mbox{(non-empty list)} \\
-%% & | & \verb+opt+~P & \mbox{(option)} \\[2ex]
-\end{array}
-\]
-\hrule
-\end{table}
-
-\section{Level 2: abstract syntax}
-
-\begin{table}
-\caption{\label{tab:wfl2} Well-formedness rules for level 2 patterns.\strut}
-\hrule
-\[
-\renewcommand{\arraystretch}{3.5}
-\begin{array}{@{}c@{}}
- \inference[\sc Constr]
- {P_i :: D_i}
- {\BLOB[P_1,\dots,P_n] :: D_i \oplus \cdots \oplus D_j} \\
- \inference[\sc TermVar]
- {}
- {\mathtt{term}~x :: x : \mathtt{Term}}
- \quad
- \inference[\sc NumVar]
- {}
- {\mathtt{number}~x :: x : \mathtt{Number}}
- \\
- \inference[\sc IdentVar]
- {}
- {\mathtt{ident}~x :: x : \mathtt{String}}
- \quad
- \inference[\sc FreshVar]
- {}
- {\mathtt{fresh}~x :: x : \mathtt{String}}
- \\
- \inference[\sc Success]
- {}
- {\mathtt{anonymous} :: \emptyset}
- \\
- \inference[\sc Fold]
- {P_1 :: D_1 & P_2 :: D_2 \oplus (x : \mathtt{Term}) & \DOMAIN(D_2)\ne\emptyset & \DOMAIN(D_1)\cap\DOMAIN(D_2)=\emptyset}
- {\mathtt{fold}~P_1~\mathtt{rec}~x~P_2 :: D_1 \oplus D_2~\mathtt{List}}
- \\
- \inference[\sc Default]
- {P_1 :: D \oplus D_1 & P_2 :: D & \DOMAIN(D_1) \ne \emptyset & \DOMAIN(D) \cap \DOMAIN(D_1) = \emptyset}
- {\mathtt{default}~P_1~P_2 :: D \oplus D_1~\mathtt{Option}}
- \\
- \inference[\sc If]
- {P_1 :: \emptyset & P_2 :: D & P_3 :: D }
- {\mathtt{if}~P_1~\mathtt{then}~P_2~\mathtt{else}~P_3 :: D}
- \qquad
- \inference[\sc Fail]
- {}
- {\mathtt{fail} :: \emptyset}
-%% & | & \verb+if+~\NT{meta}~\verb+then+~\NT{meta}~\verb+else+~\NT{meta} \\
-%% & | & \verb+fail+
-\end{array}
-\]
-\hrule
-\end{table}
-
-\begin{table}
- \caption{\label{tab:il2f1} Instantiation of level 2 patterns from level 1.
- \strut}
-\hrule
-\[
-\begin{array}{rcll}
-
-\IOT{C[t_1,\dots,t_n]}{\mathcal{E}} & =
-& C[\IOT{t_1}{\mathcal{E}},\dots,\IOT{t_n}{\mathcal{E}}] \\
-
-\IOT{\mathtt{term}~x}{\mathcal{E}} & = & t & \mathcal{E}(x) = \mathtt{Term}~t \\
-
-\IOT{\mathtt{number}~x}{\mathcal{E}} & =
-& n & \mathcal{E}(x) = \mathtt{Number}~n \\
-
-\IOT{\mathtt{ident}~x}{\mathcal{E}} & =
-& y & \mathcal{E}(x) = \mathtt{String}~y \\
-
-\IOT{\mathtt{fresh}~x}{\mathcal{E}} & = & y & \mathcal{E}(x) = \mathtt{String}~y \\
-
-\IOT{\mathtt{default}~P_1~P_2}{\mathcal{E}} & =
-& \IOT{P_1}{\UPDATE{\mathcal{E}}{x_i|->v_i}}
-& \mathcal{E}(x_i)=\mathtt{Some}~v_i \\
-& & & \NAMES(P_1)\setminus\NAMES(P_2)=\{x_1,\dots,x_n\} \\
-
-\IOT{\mathtt{default}~P_1~P_2}{\mathcal{E}} & =
-& \IOT{P_2}{\UPDATE{\mathcal{E}}{x_i|->\bot}}
-& \mathcal{E}(x_i)=\mathtt{None} \\
-& & & \NAMES(P_1)\setminus\NAMES(P_2)=\{x_1,\dots,x_n\} \\
-
-\IOT{\mathtt{fold}~\mathtt{right}~P_1~\mathtt{rec}~x~P_2}{\mathcal{E}}
-& =
-& \IOT{P_1}{\mathcal{E}'}
-& \mathcal{E}(\NAMES(P_2)\setminus\{x\}) = \{[],\dots,[]\} \\
-& & \multicolumn{2}{l}{\mathcal{E}'=\UPDATE{\mathcal{E}}{\NAMES(P_2)\setminus\{x\}|->\bot}}
-\\
-
-\IOT{\mathtt{fold}~\mathtt{right}~P_1~\mathtt{rec}~x~P_2}{\mathcal{E}}
-& =
-& \IOT{P_2}{\mathcal{E}'}
-& \mathcal{E}(y_i) = [v_{i1},\dots,v_{in}] \\
-& & & \NAMES(P_2)\setminus\{x\}=\{y_1,\dots,y_m\} \\
-& & \multicolumn{2}{l}{\mathcal{E}'(y) =
- \left\{
- \begin{array}{@{}ll}
- \IOT{\mathtt{fold}~\mathtt{right}~P_1~\mathtt{rec}~x~P_e}{\mathcal{E}''}
- & y=x \\
- v_{i1} & y=y_i \\
- \mathcal{E}(y) & \mbox{otherwise} \\
- \end{array}
- \right.} \\
-& & \multicolumn{2}{l}{\mathcal{E}''(y) =
- \left\{
- \begin{array}{@{}ll}
- [v_{i2};\dots;v_{in}] & y=y_i \\
- \mathcal{E}(y) & \mbox{otherwise} \\
- \end{array}
- \right.} \\
-
-\IOT{\mathtt{fold}~\mathtt{left}~P_1~\mathtt{rec}~x~P_2}{\mathcal{E}}
-& =
-& \mathit{eval\_fold}(x,P_2,\mathcal{E}')
-& \\
-& & \multicolumn{2}{l}{\mathcal{E}' = \UPDATE{\mathcal{E}}{x|->
-\IOT{P_1}{\UPDATE{\mathcal{E}}{\NAMES(P_2)|->\bot}}}} \\
-
-\mathit{eval\_fold}(x,P,\mathcal{E})
-& =
-& \mathcal{E}(x)
-& \mathcal{E}(\NAMES(P)\setminus\{x\})=\{[],\dots,[]\} \\
-
-\mathit{eval\_fold}(x,P,\mathcal{E})
-& =
-& \mathit{eval\_fold}(x,P,\mathcal{E}')
-& \mathcal{E}(y_i) = [v_{i1},\dots,v_{in}] \\
-& & & \NAMES(P)\setminus{x}=\{y_1,\dots,y_m\} \\
-&
-& \multicolumn{2}{l}{\mathcal{E}' = \UPDATE{\mathcal{E}}{x|->\IOT{P}{\mathcal{E}''}; ~ y_i |-> [v_{i2};\dots;v_{in_i}]}}
-\\
-&
-& \multicolumn{2}{l}{\mathcal{E}''(y) =
-\left\{
-\begin{array}{ll}
- v_1 & y\in \NAMES(P)\setminus\{x\} \\
- \mathcal{E}(x) & y=x \\
- \bot & \mathit{otherwise} \\
-\end{array}
-\right.
-}
-\\
-
-\end{array} \\
-\]
-\end{table}
-
-\begin{table}
-\caption{\label{tab:l2match} Pattern matching of level 2 terms.\strut}
-\hrule
-\[
-\renewcommand{\arraystretch}{3.5}
-\begin{array}{@{}c@{}}
- \inference[\sc Constr]
- {t_i \in P_i ~> \mathcal E_i & i\ne j => \DOMAIN(\mathcal E_i)\cap\DOMAIN(\mathcal E_j)=\emptyset}
- {C[t_1,\dots,t_n] \in C[P_1,\dots,P_n] ~> \mathcal E_1 \oplus \cdots \oplus \mathcal E_n}
- \\
- \inference[\sc TermVar]
- {}
- {t \in [\mathtt{term}]~x ~> [x |-> \mathtt{Term}~t]}
- \quad
- \inference[\sc NumVar]
- {}
- {n \in \mathtt{number}~x ~> [x |-> \mathtt{Number}~n]}
- \\
- \inference[\sc IdentVar]
- {}
- {x \in \mathtt{ident}~x ~> [x |-> \mathtt{String}~x]}
- \quad
- \inference[\sc FreshVar]
- {}
- {x \in \mathtt{fresh}~x ~> [x |-> \mathtt{String}~x]}
- \\
- \inference[\sc Success]
- {}
- {t \in \mathtt{anonymous} ~> \emptyset}
- \\
- \inference[\sc DefaultT]
- {t \in P_1 ~> \mathcal E}
- {t \in \mathtt{default}~P_1~P_2 ~> \mathcal E'}
- \quad
- \mathcal E'(x) = \left\{
- \renewcommand{\arraystretch}{1}
- \begin{array}{ll}
- \mathtt{Some}~\mathcal{E}(x) & x \in \NAMES(P_1) \setminus \NAMES(P_2) \\
- \mathcal{E}(x) & \mbox{otherwise}
- \end{array}
- \right.
- \\
- \inference[\sc DefaultF]
- {t \not\in P_1 & t \in P_2 ~> \mathcal E}
- {t \in \mathtt{default}~P_1~P_2 ~> \mathcal E'}
- \quad
- \mathcal E'(x) = \left\{
- \renewcommand{\arraystretch}{1}
- \begin{array}{ll}
- \mathtt{None} & x \in \NAMES(P_1) \setminus \NAMES(P_2) \\
- \mathcal{E}(x) & \mbox{otherwise}
- \end{array}
- \right.
- \\
- \inference[\sc IfT]
- {t \in P_1 ~> \mathcal E' & t \in P_2 ~> \mathcal E}
- {t \in \mathtt{if}~P_1~\mathtt{then}~P_2~\mathtt{else}~P_3 ~> \mathcal E}
- \quad
- \inference[\sc IfF]
- {t \not\in P_1 & t \in P_3 ~> \mathcal E}
- {t \in \mathtt{if}~P_1~\mathtt{then}~P_2~\mathtt{else}~P_3 ~> \mathcal E}
- \\
- \inference[\sc FoldRec]
- {t \in P_2 ~> \mathcal E & \mathcal{E}(x) \in \mathtt{fold}~d~P_1~\mathtt{rec}~x~P_2 ~> \mathcal E'}
- {t \in \mathtt{fold}~d~P_1~\mathtt{rec}~x~P_2 ~> \mathcal E''}
- \\
- \mbox{where}~\mathcal{E}''(y) = \left\{
- \renewcommand{\arraystretch}{1}
- \begin{array}{ll}
- \mathcal{E}(y)::\mathcal{E}'(y) & y \in \NAMES(P_2) \setminus \{x\} \wedge d = \mathtt{right} \\
- \mathcal{E}'(y)@[\mathcal{E}(y)] & y \in \NAMES(P_2) \setminus \{x\} \wedge d = \mathtt{left} \\
- \mathcal{E}'(y) & \mbox{otherwise}
- \end{array}
- \right.
- \\
- \inference[\sc FoldBase]
- {t \not\in P_2 & t \in P_1 ~> \mathcal E}
- {t \in \mathtt{fold}~P_1~\mathtt{rec}~x~P_2 ~> \mathcal E'}
- \quad
- \mathcal E'(y) = \left\{
- \renewcommand{\arraystretch}{1}
- \begin{array}{ll}
- [] & y \in \NAMES(P_2) \setminus \{x\} \\
- \mathcal{E}(y) & \mbox{otherwise}
- \end{array}
- \right.
-\end{array}
-\]
-\hrule
-\end{table}
-
-\begin{table}
- \caption{\label{tab:synl3} Abstract syntax of level 3 terms and patterns.}
- \hrule
- \[
- \begin{array}{@{}ll@{}}
- \begin{array}[t]{rcll}
- T & : := & & \mbox{(\bf terms)} \\
- & & u & \mbox{(uri)} \\
- & | & \lambda x.T & \mbox{($\lambda$-abstraction)} \\
- & | & (T_1 \dots T_n) & \mbox{(application)} \\
- & | & \dots \\[2ex]
- \end{array} &
- \begin{array}[t]{rcll}
- P & : := & & \mbox{(\bf patterns)} \\
- & & u & \mbox{(uri)} \\
- & | & V & \mbox{(variable)} \\
- & | & (P_1 \dots P_n) & \mbox{(application)} \\[2ex]
- V & : := & & \mbox{(\bf variables)} \\
- & & \TVAR{x} & \mbox{(term variable)} \\
- & | & \IMPVAR & \mbox{(implicit variable)} \\
- \end{array} \\
- \end{array}
- \]
- \hrule
-\end{table}
-
-\begin{table}
-\caption{\label{tab:wfl3} Well-formedness rules for level 3 patterns.\strut}
-\hrule
-\[
-\renewcommand{\arraystretch}{3.5}
-\begin{array}{@{}c@{}}
- \inference[\sc Uri] {} {u :: \emptyset} \quad
- \inference[\sc ImpVar] {} {\TVAR{x} :: \emptyset} \quad
- \inference[\sc TermVar] {} {\TVAR{x} :: x:\mathtt{Term}} \\
- \inference[\sc Appl]
- {P_i :: D_i
- \quad \forall i,j,i\neq j=>\DOMAIN(D_i)\cap\DOMAIN(D_j)=\emptyset}
- {P_1\cdots P_n :: D_1\oplus\cdots\oplus D_n} \\
-\end{array}
-\]
-\hrule
-\end{table}
-
-\begin{table}
- \caption{\label{tab:synargp} Abstract syntax of applicative symbol patterns.}
- \hrule
- \[
- \begin{array}{rcll}
- P & : := & & \mbox{(\bf patterns)} \\
- & & s ~ \{ \mathit{arg} \} & \mbox{(symbol pattern)} \\[2ex]
- \mathit{arg} & : := & & \mbox{(\bf argument)} \\
- & & \TVAR{x} & \mbox{(term variable)} \\
- & | & \eta.\mathit{arg} & \mbox{($\eta$-abstraction)} \\
- \end{array}
- \]
- \hrule
-\end{table}
-
-\begin{table}
-\caption{\label{tab:wfargp} Well-formedness rules for applicative symbol
-patterns.\strut}
-\hrule
-\[
-\renewcommand{\arraystretch}{3.5}
-\begin{array}{@{}c@{}}
- \inference[\sc Pattern]
- {\mathit{arg}_i :: D_i
- \quad \forall i,j,i\neq j=>\DOMAIN(D_i)\cap\DOMAIN(D_j)=\emptyset}
- {s~\mathit{arg}_1\cdots\mathit{arg}_n :: D_1\oplus\cdots\oplus D_n} \\
- \inference[\sc TermVar]
- {}
- {\TVAR{x} :: x : \mathtt{Term}}
- \quad
- \inference[\sc EtaAbs]
- {\mathit{arg} :: D}
- {\eta.\mathit{arg} :: D}
- \\
-\end{array}
-\]
-\hrule
-\end{table}
-
-\begin{table}
-\caption{\label{tab:l3match} Pattern matching of level 3 terms.\strut}
-\hrule
-\[
-\renewcommand{\arraystretch}{3.5}
-\begin{array}{@{}c@{}}
- \inference[\sc Uri] {} {u\in u ~> []} \quad
- \inference[\sc Appl] {t_i\in P_i ~> \mathcal{E}_i}
- {(t_1\dots t_n)\in(P_1\dots P_n) ~>
- \mathcal{E}_1\oplus\cdots\oplus\mathcal{E}_n} \\
- \inference[\sc TermVar] {} {t\in \TVAR{x} ~> [x |-> \mathtt{Term}~t]} \quad
- \inference[\sc ImpVar] {} {t\in \IMPVAR ~> []} \\
-\end{array}
-\]
-\hrule
-\end{table}
-
-\begin{table}
-\caption{\label{tab:iapf3} Instantiation of applicative symbol patterns (from
-level 3).\strut}
-\hrule
-\[
-\begin{array}{rcll}
- \IAP{s~a_1\cdots a_n}{\mathcal{E}} & = &
- (s~\IAPP{a_1}{\mathcal{E}}{0}\cdots\IAPP{a_n}{\mathcal{E}}{0}) & \\
- \IAPP{\TVAR{x}}{\mathcal{E}}{0} & = & t & \mathcal{E}(x)=\mathtt{Term}~t \\
- \IAPP{\TVAR{x}}{\mathcal{E}}{i+1} & = & \lambda y.\IAPP{t}{\mathcal{E}}{i}
- & \mathcal{E}(x)=\mathtt{Term}~\lambda y.t \\
- \IAPP{\TVAR{x}}{\mathcal{E}}{i+1} & =
- & \lambda y_1.\cdots.\lambda y_{i+1}.t~y_1\cdots y_{i+1}
- & \mathcal{E}(x)=\mathtt{Term}~t\wedge\forall y,t\neq\lambda y.t \\
- \IAPP{\eta.a}{\mathcal{E}}{i} & = & \IAPP{a}{\mathcal{E}}{i+1} \\
-\end{array}
-\]
-\hrule
-\end{table}
-
-\section{Type checking}
-
-\subsection{Level 1 $<->$ Level 2}
-
-\newcommand{\GUARDED}{\mathit{guarded}}
-\newcommand{\TRUE}{\mathit{true}}
-\newcommand{\FALSE}{\mathit{false}}
-
-\newcommand{\TN}{\mathit{tn}}
-
-\begin{table}
-\caption{\label{tab:guarded} Guarded condition of level 2
-pattern. Note that the recursive case of the \texttt{fold} magic is
-not explicitly required to be guarded. The point is that it must
-contain at least two distinct names, and this guarantees that whatever
-is matched by the recursive pattern, the terms matched by those two
-names will be smaller than the whole matched term.\strut} \hrule
-\[
-\begin{array}{rcll}
- \GUARDED(C(M(P))) & = & \GUARDED(P) \\
- \GUARDED(C(t_1,\dots,t_n)) & = & \TRUE \\
- \GUARDED(\mathtt{term}~x) & = & \FALSE \\
- \GUARDED(\mathtt{number}~x) & = & \FALSE \\
- \GUARDED(\mathtt{ident}~x) & = & \FALSE \\
- \GUARDED(\mathtt{fresh}~x) & = & \FALSE \\
- \GUARDED(\mathtt{anonymous}) & = & \TRUE \\
- \GUARDED(\mathtt{default}~P_1~P_2) & = & \GUARDED(P_1) \wedge \GUARDED(P_2) \\
- \GUARDED(\mathtt{if}~P_1~\mathtt{then}~P_2~\mathtt{else}~P_3) & = & \GUARDED(P_2) \wedge \GUARDED(P_3) \\
- \GUARDED(\mathtt{fail}) & = & \TRUE \\
- \GUARDED(\mathtt{fold}~d~P_1~\mathtt{rec}~x~P_2) & = & \GUARDED(P_1)
-\end{array}
-\]
-\hrule
-\end{table}
-
-%% Assume that we have two corresponding patterns $P_1$ (level 1) and
-%% $P_2$ (level 2) and that we have to check whether they are
-%% ``correct''. First we define the notion of \emph{top-level names} of
-%% $P_1$ and $P_2$, as follows:
-%% \[
-%% \begin{array}{rcl}
-%% \TN(C_1[P'_1,\dots,P'_2]) & = & \TN(P'_1) \cup \cdots \cup \TN(P'_2) \\
-%% \TN(\TVAR{x}) & = & \{x\} \\
-%% \TN(\NVAR{x}) & = & \{x\} \\
-%% \TN(\IVAR{x}) & = & \{x\} \\
-%% \TN(\mathtt{list0}~P'~l?) & = & \emptyset \\
-%% \TN(\mathtt{list1}~P'~l?) & = & \emptyset \\
-%% \TN(\mathtt{opt}~P') & = & \emptyset \\[3ex]
-%% \TN(\BLOB(P''_1,\dots,P''_2)) & = & \TN(P''_1) \cup \cdots \cup \TN(P''_2) \\
-%% \TN(\mathtt{term}~x) & = & \{x\} \\
-%% \TN(\mathtt{number}~x) & = & \{x\} \\
-%% \TN(\mathtt{ident}~x) & = & \{x\} \\
-%% \TN(\mathtt{fresh}~x) & = & \{x\} \\
-%% \TN(\mathtt{anonymous}) & = & \emptyset \\
-%% \TN(\mathtt{fold}~P''_1~\mathtt{rec}~x~P''_2) & = & \TN(P''_1) \\
-%% \TN(\mathtt{default}~P''_1~P''_2) & = & \TN(P''_1) \cap \TN(P''_2) \\
-%% \TN(\mathtt{if}~P''_1~\mathtt{then}~P''_2~\mathtt{else}~P''_3) & = & \TN(P''_2) \\
-%% \TN(\mathtt{fail}) & = & \emptyset
-%% \end{array}
-%% \]
-
-We say that a \emph{bidirectional transformation}
-\[
- P_1 <=> P_2
-\]
-is well-formed if:
-\begin{itemize}
- \item $P_1$ is a well-formed \emph{level 1 pattern} in some context $D$ and
- $P_2$ is a well-formed \emph{level 2 pattern} in the very same context $D$,
- that is $P_1 :: D$ and $P_2 :: D$;
- \item the pattern $P_2$ is guarded, that is $\GUARDED(P_2)=\TRUE$;
- \item for any direct sub-pattern $\mathtt{opt}~P'_1$ of $P_1$ such
- that $\mathtt{opt}~P'_1 :: X$ there is a sub-pattern
- $\mathtt{default}~P'_2~P''_2$ of $P_2$ such that
- $\mathtt{default}~P'_2~P''_2 :: X \oplus Y$ for some context $Y$;
- \item for any direct sub-pattern $\mathtt{list}~P'_1~l?$ of $P_1$
- such that $\mathtt{list}~P'_1~l? :: X$ there is a sub-pattern
- $\mathtt{fold}~P'_2~\mathtt{rec}~x~P''_2$ of $P_2$ such that
- $\mathtt{fold}~P'_2~\mathtt{rec}~x~P''_2 :: X \oplus Y$ for some
- context $Y$.
-\end{itemize}
-
-A \emph{left-to-right transformation}
-\[
- P_1 => P_2
-\]
-is well-formed if $P_2$ does not contain \texttt{if}, \texttt{fail},
-or \texttt{anonymous} meta patterns.
-
-Note that the transformations are in a sense asymmetric. Moving from
-the concrete syntax (level 1) to the abstract syntax (level 2) we
-forget about syntactic details. Moving from the abstract syntax to the
-concrete syntax we may want to forget about redundant structure
-(types).
-
-Relationship with grammatical frameworks?
-
-\subsection{Level 2 $<->$ Level 3}
-
-We say that an \emph{interpretation}
-\[
- P_2 <=> P_3
-\]
-is well-formed if:
-\begin{itemize}
- \item $P_2$ is a well-formed \emph{applicative symbol pattern} in some context
- $D$ and $P_3$ is a well-formed \emph{level 3 pattern} in the very same
- context $D$, that is $P_2 :: D$ and $P_3 :: D$.
-\end{itemize}
-
-\section{Semantic selection}
-
+++ /dev/null
-%%
-%% This is file `infernce.sty',
-%% generated with the docstrip utility.
-%%
-%% The original source files were:
-%%
-%% semantic.dtx (with options: `allOptions,inference')
-%%
-%% IMPORTANT NOTICE:
-%%
-%% For the copyright see the source file.
-%%
-%% Any modified versions of this file must be renamed
-%% with new filenames distinct from infernce.sty.
-%%
-%% For distribution of the original source see the terms
-%% for copying and modification in the file semantic.dtx.
-%%
-%% This generated file may be distributed as long as the
-%% original source files, as listed above, are part of the
-%% same distribution. (The sources need not necessarily be
-%% in the same archive or directory.)
-%%
-%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and
-%% Arne John Glenstrup
-%%
-\expandafter\ifx\csname sem@nticsLoader\endcsname\relax
- \PackageError{semantic}{%
- This file should not be loaded directly}
- {%
- This file is an option of the semantic package. It should not be
- loaded directly\MessageBreak
- but by using \protect\usepackage{semantic} in your document
- preamble.\MessageBreak
- No commands are defined.\MessageBreak
- Type <return> to proceed.
- }%
-\else
-\TestForConflict{\@@tempa,\@@tempb,\@adjustPremises,\@inference}
-\TestForConflict{\@inferenceBack,\@inferenceFront,\@inferenceOrPremis}
-\TestForConflict{\@premises,\@processInference,\@processPremiseLine}
-\TestForConflict{\@setLengths,\inference,\predicate,\predicatebegin}
-\TestForConflict{\predicateend,\setnamespace,\setpremisesend}
-\TestForConflict{\setpremisesspace,\@makeLength,\@@space}
-\TestForConflict{\@@aLineBox,\if@@shortDivider}
-\newtoks\@@tempa
-\newtoks\@@tempb
-\newcommand{\@makeLength}[4]{
- \@@tempa=\expandafter{\csname @@#2\endcsname}
- \@@tempb=\expandafter{\csname @set#2\endcsname} %
- \expandafter \newlength \the\@@tempa
- \expandafter \newcommand \the\@@tempb {}
- \expandafter \newcommand \csname set#1\endcsname[1]{}
- \expandafter \xdef \csname set#1\endcsname##1%
- {{\dimen0=##1}%
- \noexpand\renewcommand{\the\@@tempb}{%
- \noexpand\setlength{\the \@@tempa}{##1 #4}}%
- }%
- \csname set#1\endcsname{#3}
- \@@tempa=\expandafter{\@setLengths} %
- \edef\@setLengths{\the\@@tempa \the\@@tempb} %
- }
-
-\newcommand{\@setLengths}{%
- \setlength{\baselineskip}{1.166em}%
- \setlength{\lineskip}{1pt}%
- \setlength{\lineskiplimit}{1pt}}
-\@makeLength{premisesspace}{pSpace}{1.5em}{plus 1fil}
-\@makeLength{premisesend}{pEnd}{.75em}{plus 0.5fil}
-\@makeLength{namespace}{nSpace}{.5em}{}
-\newbox\@@aLineBox
-\newif\if@@shortDivider
-\newcommand{\@@space}{ }
-\newcommand{\predicate}[1]{\predicatebegin #1\predicateend}
-\newcommand{\predicatebegin}{$}
-\newcommand{\predicateend}{$}
-\def\inference{%
- \@@shortDividerfalse
- \expandafter\hbox\bgroup
- \@ifstar{\@@shortDividertrue\@inferenceFront}%
- \@inferenceFront
-}
-\def\@inferenceFront{%
- \@ifnextchar[%
- {\@inferenceFrontName}%
- {\@inferenceMiddle}%
-}
-\def\@inferenceFrontName[#1]{%
- \setbox3=\hbox{\footnotesize #1}%
- \ifdim \wd3 > \z@
- \unhbox3%
- \hskip\@@nSpace
- \fi
- \@inferenceMiddle
-}
-\long\def\@inferenceMiddle#1{%
- \@setLengths%
- \setbox\@@pBox=
- \vbox{%
- \@premises{#1}%
- \unvbox\@@pBox
- }%
- \@inferenceBack
-}
-\long\def\@inferenceBack#1{%
- \setbox\@@cBox=%
- \hbox{\hskip\@@pEnd \predicate{\ignorespaces#1}\unskip\hskip\@@pEnd}%
- \setbox1=\hbox{$ $}%
- \setbox\@@pBox=\vtop{\unvbox\@@pBox
- \vskip 4\fontdimen8\textfont3}%
- \setbox\@@cBox=\vbox{\vskip 4\fontdimen8\textfont3%
- \box\@@cBox}%
- \if@@shortDivider
- \ifdim\wd\@@pBox >\wd\@@cBox%
- \dimen1=\wd\@@pBox%
- \else%
- \dimen1=\wd\@@cBox%
- \fi%
- \dimen0=\wd\@@cBox%
- \hbox to \dimen1{%
- \hss
- $\frac{\hbox to \dimen0{\hss\box\@@pBox\hss}}%
- {\box\@@cBox}$%
- \hss
- }%
- \else
- $\frac{\box\@@pBox}%
- {\box\@@cBox}$%
- \fi
- \@ifnextchar[%
- {\@inferenceBackName}%{}%
- {\egroup}
-}
-\def\@inferenceBackName[#1]{%
- \setbox3=\hbox{\footnotesize #1}%
- \ifdim \wd3 > \z@
- \hskip\@@nSpace
- \unhbox3%
- \fi
- \egroup
-}
-\newcommand{\@premises}[1]{%
- \setbox\@@pBox=\vbox{}%
- \dimen\@@maxwidth=\wd\@@cBox%
- \@processPremises #1\\\end%
- \@adjustPremises%
-}
-\newcommand{\@adjustPremises}{%
- \setbox\@@pBox=\vbox{%
- \@@moreLinestrue %
- \loop %
- \setbox\@@pBox=\vbox{%
- \unvbox\@@pBox %
- \global\setbox\@@aLineBox=\lastbox %
- }%
- \ifvoid\@@aLineBox %
- \@@moreLinesfalse %
- \else %
- \hbox to \dimen\@@maxwidth{\unhbox\@@aLineBox}%
- \fi %
- \if@@moreLines\repeat%
- }%
-}
-\def\@processPremises#1\\#2\end{%
- \setbox\@@pLineBox=\hbox{}%
- \@processPremiseLine #1&\end%
- \setbox\@@pLineBox=\hbox{\unhbox\@@pLineBox \unskip}%
- \ifdim \wd\@@pLineBox > \z@ %
- \setbox\@@pLineBox=%
- \hbox{\hskip\@@pEnd \unhbox\@@pLineBox \hskip\@@pEnd}%
- \ifdim \wd\@@pLineBox > \dimen\@@maxwidth %
- \dimen\@@maxwidth=\wd\@@pLineBox %
- \fi %
- \setbox\@@pBox=\vbox{\box\@@pLineBox\unvbox\@@pBox}%
- \fi %
- \def\sem@tmp{#2}%
- \ifx \sem@tmp\empty \else %
- \@ReturnAfterFi{%
- \@processPremises #2\end %
- }%
- \fi%
-}
-\def\@processPremiseLine#1\end{%
- \def\sem@tmp{#1}%
- \ifx \sem@tmp\empty \else%
- \ifx \sem@tmp\@@space \else%
- \setbox\@@pLineBox=%
- \hbox{\unhbox\@@pLineBox%
- \@inferenceOrPremis #1\inference\end%
- \hskip\@@pSpace}%
- \fi%
- \fi%
- \def\sem@tmp{#2}%
- \ifx \sem@tmp\empty \else%
- \@ReturnAfterFi{%
- \@processPremiseLine#2\end%
- }%
- \fi%
-}
-\def\@inferenceOrPremis#1\inference{%
- \@ifnext \end
- {\@dropnext{\predicate{\ignorespaces #1}\unskip}}%
- {\@processInference #1\inference}%
-}
-\def\@processInference#1\inference\end{%
- \ignorespaces #1%
- \setbox3=\lastbox
- \dimen3=\dp3
- \advance\dimen3 by -\fontdimen22\textfont2
- \advance\dimen3 by \fontdimen8\textfont3
- \expandafter\raise\dimen3\box3%
-}
-\long\def\@ReturnAfterFi#1\fi{\fi#1}
-\fi
-\endinput
-%%
-%% End of file `infernce.sty'.
+++ /dev/null
-%%
-%% This is file `ligature.sty',
-%% generated with the docstrip utility.
-%%
-%% The original source files were:
-%%
-%% semantic.dtx (with options: `allOptions,ligature')
-%%
-%% IMPORTANT NOTICE:
-%%
-%% For the copyright see the source file.
-%%
-%% Any modified versions of this file must be renamed
-%% with new filenames distinct from ligature.sty.
-%%
-%% For distribution of the original source see the terms
-%% for copying and modification in the file semantic.dtx.
-%%
-%% This generated file may be distributed as long as the
-%% original source files, as listed above, are part of the
-%% same distribution. (The sources need not necessarily be
-%% in the same archive or directory.)
-%%
-%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and
-%% Arne John Glenstrup
-%%
-\expandafter\ifx\csname sem@nticsLoader\endcsname\relax
- \PackageError{semantic}{%
- This file should not be loaded directly}
- {%
- This file is an option of the semantic package. It should not be
- loaded directly\MessageBreak
- but by using \protect\usepackage{semantic} in your document
- preamble.\MessageBreak
- No commands are defined.\MessageBreak
- Type <return> to proceed.
- }%
-\else
-\TestForConflict{\@addligto,\@addligtofollowlist,\@def@ligstep}
-\TestForConflict{\@@trymathlig,\@defactive,\@defligstep}
-\TestForConflict{\@definemathlig,\@domathligfirsts,\@domathligfollows}
-\TestForConflict{\@exitmathlig,\@firstmathligs,\@ifactive,\@ifcharacter}
-\TestForConflict{\@ifinlist,\@lastvalidmathlig,\@mathliglink}
-\TestForConflict{\@mathligredefactive,\@mathligsoff,\@mathligson}
-\TestForConflict{\@seentoks,\@setupfirstligchar,\@try@mathlig}
-\TestForConflict{\@trymathlig,\if@mathligon,\mathlig,\mathligprotect}
-\TestForConflict{\mathligsoff,\mathligson,\@startmathlig,\@pushedtoks}
-\newif\if@mathligon
-\DeclareRobustCommand\mathlig[1]{\@addligtolists#1\@@
- \if@mathligon\mathligson\fi
- \@setupfirstligchar#1\@@
- \@defligstep{}#1\@@}
-\def\@mathligson{\if@mathligon\mathligson\fi}
-\def\@mathligsoff{\if@mathligon\mathligsoff\@mathligontrue\fi}
-\DeclareRobustCommand\mathligprotect[1]{\expandafter
- \def\expandafter#1\expandafter{%
- \expandafter\@mathligsoff#1\@mathligson}}
-\DeclareRobustCommand\mathligson{\def\do##1##2##3{\mathcode`##1="8000}%
- \@domathligfirsts\@mathligontrue}
-\AtBeginDocument{\mathligson}
-\DeclareRobustCommand\mathligsoff{\def\do##1##2##3{\mathcode`##1=##2}%
- \@domathligfirsts\@mathligonfalse}
-\edef\@mathliglink{Error: \noexpand\verb|\string\@mathliglink| expanded}
-{\catcode`\A=11\catcode`\1=12\catcode`\~=13 % Letter, Other and Active
-\gdef\@ifcharacter#1{\ifcat A\noexpand#1\let\next\@firstoftwo
- \else\ifcat 1\noexpand#1\let\next\@firstoftwo
- \else\ifcat \noexpand~\noexpand#1\let\next\@firstoftwo
- \else\let\next\@secondoftwo\fi\fi\fi\next}%
-\gdef\@ifactive#1{\ifcat \noexpand~\noexpand#1\let\next\@firstoftwo
- \else\let\next\@secondoftwo\fi\next}}
-\def\@domathligfollows{}\def\@domathligfirsts{}
-\def\@makemathligsactive{\mathligson
- \def\do##1##2##3{\catcode`##1=12}\@domathligfollows}
-\def\@makemathligsnormal{\mathligsoff
- \def\do##1##2##3{\catcode`##1=##3}\@domathligfollows}
-\def\@ifinlist#1#2{\@tempswafalse
- \def\do##1##2##3{\ifnum`##1=`#2\relax\@tempswatrue\fi}#1%
- \if@tempswa\let\next\@firstoftwo\else\let\next\@secondoftwo\fi\next}
-\def\@addligto#1#2{%
- \@ifinlist#1#2{\def\do##1##2##3{\noexpand\do\noexpand##1%
- \ifnum`##1=`#2 {\the\mathcode`#2}{\the\catcode`#2}%
- \else{##2}{##3}\fi}%
- \edef#1{#1}}%
- {\def\do##1##2##3{\noexpand\do\noexpand##1%
- \ifnum`##1=`#2 {\the\mathcode`#2}{\the\catcode`#2}%
- \else{##2}{##3}\fi}%
- \edef#1{#1\do#2{\the\mathcode`#2}{\the\catcode`#2}}}}
-\def\@addligtolists#1{\expandafter\@addligto
- \expandafter\@domathligfirsts
- \csname\string#1\endcsname\@addligtofollowlist}
-\def\@addligtofollowlist#1{\ifx#1\@@\let\next\relax\else
- \def\next{\expandafter\@addligto
- \expandafter\@domathligfollows
- \csname\string#1\endcsname
- \@addligtofollowlist}\fi\next}
-\def\@defligstep#1#2{\def\@tempa##1{\ifx##1\endcsname
- \expandafter\endcsname\else
- \string##1\expandafter\@tempa\fi}%
- \expandafter\@def@ligstep\csname @mathlig\@tempa#1#2\endcsname{#1#2}}
-\def\@def@ligstep#1#2#3{%
- \ifx#3\@@
- \def\next{\def#1}%
- \else
- \ifx#1\relax
- \def\next{\let#1\@mathliglink\@defligstep{#2}#3}%
- \else
- \def\next{\@defligstep{#2}#3}%
- \fi
- \fi\next}
-\def\@setupfirstligchar#1#2\@@{%
- \@ifactive{#1}{%
- \expandafter\expandafter\expandafter\@mathligredefactive
- \expandafter\string\expandafter#1\expandafter{#1}{#1}}%
- {\@defactive#1{\@startmathlig #1}\@namedef{@mathlig#1}{#1}}}
-\def\@mathligredefactive#1#2#3{%
- \def#3{{}\ifmmode\def\next{\@startmathlig#1}\else
- \def\next{#2}\fi\next}%
- \@namedef{@mathlig#1}{#2}}
-\def\@defactive#1{\@ifundefined{@definemathlig\string#1}%
- {\@latex@error{Illegal first character in math ligature}
- {You can only use \@firstmathligs\space as the first^^J
- character of a math ligature}}%
- {\csname @definemathlig\string#1\endcsname}}
-
-{\def\@firstmathligs{}\def\do#1{\catcode`#1=\active
- \expandafter\gdef\expandafter\@firstmathligs
- \expandafter{\@firstmathligs\space\string#1}\next}
- \def\next#1{\expandafter\gdef\csname
- @definemathlig\string#1\endcsname{\def#1}}
- \do{"}"\do{@}@\do{/}/\do{(}(\do{)})\do{[}[\do{]}]\do{=}=
- \do{?}?\do{!}!\do{`}`\do{'}'\do{|}|\do{~}~\do{<}<\do{>}>
- \do{+}+\do{-}-\do{*}*\do{.}.\do{,},\do{:}:\do{;};}
-\newtoks\@pushedtoks
-\newtoks\@seentoks
-\def\@startmathlig{\def\@lastvalidmathlig{}\@pushedtoks{}%
- \@seentoks{}\@trymathlig}
-\def\@trymathlig{\futurelet\next\@@trymathlig}
-\def\@@trymathlig{\@ifcharacter\next{\@try@mathlig}{\@exitmathlig{}}}
-\def\@exitmathlig#1{%
- \expandafter\@makemathligsnormal\@lastvalidmathlig\mathligson
- \the\@pushedtoks#1}
-\def\@try@mathlig#1{%\typeout{char: #1 catcode: \the\catcode`#1
- \@ifundefined{@mathlig\the\@seentoks#1}{\@exitmathlig{#1}}%
- {\expandafter\ifx
- \csname @mathlig\the\@seentoks#1\endcsname
- \@mathliglink
- \expandafter\@pushedtoks
- \expandafter=\expandafter{\the\@pushedtoks#1}%
- \else
- \expandafter\let\expandafter\@lastvalidmathlig
- \csname @mathlig\the\@seentoks#1\endcsname
- \@pushedtoks={}%
- \fi
- \expandafter\@seentoks\expandafter=\expandafter%
- {\the\@seentoks#1}\@makemathligsactive\obeyspaces\@trymathlig}}
-\edef\patch@newmcodes@{%
- \mathcode\number`\'=39
- \mathcode\number`\*=42
- \mathcode\number`\.=\string "613A
- \mathchardef\noexpand\std@minus=\the\mathcode`\-\relax
- \mathcode\number`\-=45
- \mathcode\number`\/=47
- \mathcode\number`\:=\string "603A\relax
-}
-\AtBeginDocument{\let\newmcodes@=\patch@newmcodes@}
-\fi
-\endinput
-%%
-%% End of file `ligature.sty'.
+++ /dev/null
-\documentclass[a4paper,draft]{article}
-
-\usepackage{manfnt}
-\usepackage{a4wide}
-\usepackage{pifont}
-\usepackage{semantic}
-\usepackage{stmaryrd,latexsym}
-
-\newcommand{\BLOB}{\raisebox{0ex}{\small\manstar}}
-
-\newcommand{\MATITA}{\ding{46}\textsf{\textbf{Matita}}}
-
-\title{Extensible notation for \MATITA}
-\author{Luca Padovani \qquad Stefano Zacchiroli \\
-\small Department of Computer Science, University of Bologna \\
-\small Mura Anteo Zamboni, 7 -- 40127 Bologna, ITALY \\
-\small \{\texttt{lpadovan}, \texttt{zacchiro}\}\texttt{@cs.unibo.it}}
-
-\newcommand{\BREAK}{\mathtt{break}}
-\newcommand{\TVAR}[1]{#1:\mathtt{term}}
-\newcommand{\IMPVAR}{\TVAR{\_}}
-\newcommand{\NVAR}[1]{#1:\mathtt{number}}
-\newcommand{\IVAR}[1]{#1:\mathtt{name}}
-\newcommand{\FENCED}[1]{\texttt{\char'050}#1\texttt{\char'051}}
-\newcommand{\ITO}[2]{|[#1|]_{\mathcal#2}^1}
-\newcommand{\IOT}[2]{|[#1|]_{#2}^2}
-\newcommand{\IAP}[2]{|[#1|]_{#2}^a}
-\newcommand{\IAPP}[3]{|[#1|]_{#2,#3}^a}
-\newcommand{\ADDPARENS}[2]{\llparenthesis#1\rrparenthesis^{#2}}
-\newcommand{\NAMES}{\mathit{names}}
-\newcommand{\DOMAIN}{\mathit{domain}}
-\newcommand{\UPDATE}[2]{#1[#2]}
-
-\mathlig{~>}{\leadsto}
-\mathlig{|->}{\mapsto}
-
-\begin{document}
- \maketitle
-
- \input{body}
-
-\end{document}
-
+++ /dev/null
-%%
-%% This is file `manfnt.sty',
-%% generated with the docstrip utility.
-%%
-%% The original source files were:
-%%
-%% manfnt.dtx
-%%
-%% Copyright (C) 1998 - 99 by Axel Kielhorn, all rights reserved
-%% Copyright (C) 1999 by Denis Kosygin, all rights reserved.
-%% For additional copyright information see further down in this file.
-%%
-%% This file is to be used with the LaTeX2e system.
-%% ------------------------------------------------
-%%
-%% This program can be redistributed and/or modified under the terms
-%% of the LaTeX Project Public License Distributed from CTAN
-%% archives in directory macros/latex/base/lppl.txt; either
-%% version 1 of the License, or any later version.
-%%
-%% Copyright (C) 1998 - 99 by Axel Kielhorn, all rights reserved
-%% Copyright (C) 1999 by Denis Kosygin, all rights reserved.
-%%
-%% This program can be redistributed and/or modified under the terms
-%% of the LaTeX Project Public License Distributed from CTAN
-%% archives in directory macros/latex/base/lppl.txt; either
-%% version 1 of the License, or any later version.
-\def\fileversion{0.2}
-\def\filedate{1999/07/01}
-\NeedsTeXFormat{LaTeX2e}
-\ProvidesPackage{manfnt}[\filedate \fileversion LaTeX2e manfnt package]
-\DeclareFontFamily{U}{manual}{}
-\DeclareFontShape{U}{manual}{m}{n}{ <-> manfnt }{}
-\newcommand{\manfntsymbol}[1]{%
- {\fontencoding{U}\fontfamily{manual}\selectfont\symbol{#1}}}
-\newcommand{\manhpennib}{\manfntsymbol{21}}
-\newcommand{\mantiltpennib}{\manfntsymbol{22}}
-\newcommand{\manvpennib}{\manfntsymbol{23}}
-\newcommand{\mankidney}{\manfntsymbol{17}}
-\newcommand{\manboldkidney}{\manfntsymbol{18}}
-\newcommand{\manpenkidney}{\manfntsymbol{19}}
-\newcommand{\manlhpenkidney}{\manfntsymbol{20}}
-\newcommand{\manquartercircle}{\manfntsymbol{32}}
-\newcommand{\manfilledquartercircle}{\manfntsymbol{33}}
-\newcommand{\manrotatedquartercircle}{\manfntsymbol{34}}
-\newcommand{\mancone}{\manfntsymbol{35}}
-\newcommand{\manconcentriccircles}{\manfntsymbol{36}}
-\newcommand{\manconcentricdiamond}{\manfntsymbol{37}}
-\newcommand{\mantriangleright}{\manfntsymbol{120}}% Triangle for exercises
-\newcommand{\mantriangleup}{% Upper triangle for Addison-Wesley logo
- \manfntsymbol{54}}
-\newcommand{\mantriangledown}{% Lower triangle for Addison-Wesley logo
- \manfntsymbol{55}}
-\newcommand{\mancube}{\manfntsymbol{28}}
-\newcommand{\manimpossiblecube}{\manfntsymbol{29}}
-\newcommand{\manquadrifolium}{\manfntsymbol{38}}% \fouru
-\newcommand{\manrotatedquadrifolium}{\manfntsymbol{39}}% \fourc
-\newcommand{\manstar}{\manfntsymbol{30}}% Bicentennial star
-\newcommand{\manerrarrow}{\manfntsymbol{121}}% Arrow for errata lists
-\newcommand{\dbend}{\manfntsymbol{127}}% Z-shaped
-\newcommand{\lhdbend}{\manfntsymbol{126}}% Lefthanded (S-shaped)
-\newcommand{\reversedvideodbend}{\manfntsymbol{0}}% Reversed video
-\newcommand{\textdbend}{\text@dbend{\dbend}}
-\newcommand{\textlhdbend}{\text@dbend{\lhdbend}}
-\newcommand{\textreversedvideodbend}{\text@dbend{\reversedvideodbend}}
-\newlength{\dbend@height}
-\newcommand{\text@dbend}[1]{%
- \settoheight{\dbend@height}{#1}%
- \divide\dbend@height by 15%
- \multiply\dbend@height by 22%
- \raisebox{\dbend@height}{#1}}
-\endinput
-%%
-%% End of file `manfnt.sty'.
+++ /dev/null
-%%
-%% This is file `reserved.sty',
-%% generated with the docstrip utility.
-%%
-%% The original source files were:
-%%
-%% semantic.dtx (with options: `allOptions,reservedWords')
-%%
-%% IMPORTANT NOTICE:
-%%
-%% For the copyright see the source file.
-%%
-%% Any modified versions of this file must be renamed
-%% with new filenames distinct from reserved.sty.
-%%
-%% For distribution of the original source see the terms
-%% for copying and modification in the file semantic.dtx.
-%%
-%% This generated file may be distributed as long as the
-%% original source files, as listed above, are part of the
-%% same distribution. (The sources need not necessarily be
-%% in the same archive or directory.)
-%%
-%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and
-%% Arne John Glenstrup
-%%
-\expandafter\ifx\csname sem@nticsLoader\endcsname\relax
- \PackageError{semantic}{%
- This file should not be loaded directly}
- {%
- This file is an option of the semantic package. It should not be
- loaded directly\MessageBreak
- but by using \protect\usepackage{semantic} in your document
- preamble.\MessageBreak
- No commands are defined.\MessageBreak
- Type <return> to proceed.
- }%
-\else
-\TestForConflict{\reservestyle,\@reservestyle,\setreserved,\<}
-\TestForConflict{\@parseDefineReserved,\@xparseDefineReserved}
-\TestForConflict{\@defineReserved,\@xdefineReserved}
-\newcommand{\reservestyle}[3][]{
- \newcommand{#2}{\@parseDefineReserved{#1}{#3}}
- \expandafter\expandafter\expandafter\def
- \expandafter\csname set\expandafter\@gobble\string#2\endcsname##1%
- {#1{#3{##1}}}}
-\newtoks\@@spacing
-\newtoks\@@formating
-\def\@parseDefineReserved#1#2{%
- \@ifnextchar[{\@xparseDefineReserved{#2}}%
- {\@xparseDefineReserved{#2}[#1]}}
-\def\@xparseDefineReserved#1[#2]#3{%
- \@@formating{#1}%
- \@@spacing{#2}%
- \expandafter\@defineReserved#3,\end
-}
-\def\@defineReserved#1,{%
- \@ifnextchar\end
- {\@xdefineReserved #1[]\END\@gobble}%
- {\@xdefineReserved#1[]\END\@defineReserved}}
-\def\@xdefineReserved#1[#2]#3\END{%
- \def\reserved@a{#2}%
- \ifx \reserved@a\empty \toks0{#1}\else \toks0{#2} \fi
- \expandafter\edef\csname\expandafter<#1>\endcsname
- {\the\@@formating{\the\@@spacing{\the\toks0}}}}
-\def\setreserved#1>{%
- \expandafter\let\expandafter\reserved@a\csname<#1>\endcsname
- \@ifundefined{reserved@a}{\PackageError{Semantic}
- {``#1'' is not defined as a reserved word}%
- {Before referring to a name as a reserved word, it %
- should be defined\MessageBreak using an appropriate style
- definer. A style definer is defined \MessageBreak
- using \protect\reservestyle.\MessageBreak%
- Type <return> to proceed --- nothing will be set.}}%
- {\reserved@a}}
-\let\<=\setreserved
-\fi
-\endinput
-%%
-%% End of file `reserved.sty'.
+++ /dev/null
-
-notation
- "\langle a , b \rangle"
-for
- @{ 'pair $a $b }.
-check \langle 1, \langle 2, 3 \rangle \rangle.
-check 'pair 1 ('pair 2 ('pair 3 4)).
-
-notation "a :: b" for @{ 'cons $a $b }.
-check 1 :: 2 :: 'ugo.
-
-notation
- "[ hovbox (list0 a sep ; ) ]"
-for ${
- fold right
- @'nil
- rec acc
- @{ 'cons $a $acc }
-}.
-check [1;2;3;4].
-
-notation
- "[ list1 a sep ; | b ]"
-for ${
- if @{ 'cons $_ $_ } then
- fold right
- if @'nil then
- fail
- else if @{ 'cons $_ $_ } then
- fail
- else
- b
- rec acc
- @{ 'cons $a $acc }
- else
- fail
-}.
-check 'cons 1 ('cons 2 ('cons 3 'ugo)).
-check 'cons 1 ('cons 2 ('cons 3 'nil)).
-check [1;2;3;4].
-check [1;2;3;4|5].
-
-notation "a + b" left associative for @{ 'plus $a $b }.
-check 1 + 2 + 3.
-check 1 + (2 + 3).
-
-notation "a + b" left associative for @{ 'plus $a $b }.
-notation "a * b" left associative for @{ 'mult $a $b }.
-interpretation 'plus x y = (cic:/Coq/Init/Peano/plus.con x y).
-interpretation 'mult x y = (cic:/Coq/Init/Peano/mult.con x y).
-render cic:/Coq/Arith/Mult/mult_plus_distr_r.con.
-
-notation
- "hvbox ('if' a 'then' break b break 'else' break c)"
-for
- @{ 'ifthenelse $a $b $c }.
-check if even then \forall x:nat.x else bump x.
-
-notation
- "a \vee b"
-for
- @{ if $a > $b then $a else $b }
-
-notation
- "'fun' ident x \to a"
- right associative with precedence 20
-for
- @{ 'lambda ${ident x} $a }.
-
-notation
- "hvbox(a break \to b)"
-for
- @{ \forall $_:$a.$b }.
-check nat \to nat.
-
-NOTES
-
-@a e' un'abbreviazione per @{term a}
-"x" e' un'abbreviazione per @{keyword x}
-@_ e' un'abbreviazione per @{anonymous}
-
-\x simbolo della sintassi concreta
-'x simbolo della sintassi astratta
-
-\lbrace \rbrace per le parentesi graffe al livello 1
-
-OLD SAMPLES
-
-# sample mappings level 1 <--> level 2
-
-notation \[ \TERM a ++ \OPT \NUM i \] for 'assign \TERM a ('plus \TERM a \DEFAULT \[\NUM i\] \[1\]).
-check 1 ++ 2.
-
-notation \[ + \LIST0 \NUM a \] for \FOLD right \[ 'zero \] \LAMBDA acc \[ 'plus \NUM a \TERM acc \].
-check + 1 2 3 4.
-
-notation \[ [ \HOVBOX\[ \LIST0 \TERM a \SEP ; \] ] \] for \FOLD right \[ 'nil \] \LAMBDA acc \[ 'cons \TERM a \TERM acc \].
-check [].
-check [1;2;3;4].
-
-notation \[ [ \LIST0 \[ \TERM a ; \TERM b \] \SEP ; ] \] for \FOLD right \[ 'nil \] \LAMBDA acc \[ 'cons \TERM a ( 'cons \TERM b \TERM acc) \] .
-check [].
-check [1;2].
-check [1;2;3;4].
-
-notation \[ | \LIST0 \[ \TERM a \OPT \[ , \TERM b \] \] \SEP ; | \] for \FOLD right \[ 'nil \] \LAMBDA acc \[ 'cons \DEFAULT \[ \TERM a \] \[ ('pair \TERM a \TERM b) \] \TERM acc \] .
-
-notation \[ | \LIST0 \[ \OPT \[ \NUM i \] \] \SEP ; | \] for \FOLD right \[ 'nil \] \LAMBDA acc \[ 'cons \DEFAULT \[ 'Some \NUM i \] \[ 'None \] \TERM acc \] .
-
-# sample mappings level 2 <--> level 3
-
-interpretation 'plus x y = (cic:/Coq/Init/Peano/plus.con x y).
-interpretation 'mult x y = (cic:/Coq/Init/Peano/mult.con x y).
-render cic:/Coq/Arith/Mult/mult_plus_distr_r.con.
-
-notation \[ \TERM a \OVER \TERM b : \TERM c \SQRT \TERM d \] for 'megacoso \TERM a \TERM b \TERM c \TERM d.
-interpretation "megacoso" 'megacoso x y z w =
- (cic:/Coq/Init/Logic/eq.ind#xpointer(1/1)
- cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)
- (cic:/Coq/Init/Peano/plus.con x y)
- (cic:/Coq/Init/Peano/plus.con z w)).
-render cic:/Coq/Arith/Plus/plus_comm.con.
-
-# full samples
-
-notation \[ \TERM a + \TERM b \] for 'plus \TERM a \TERM b.
-check 1 + 2.
-interpretation 'plus x y = (cic:/Coq/Init/Peano/plus.con x y).
-render cic:/Coq/Arith/Plus/plus_comm.con.
-
-notation \[ \TERM a + \TERM b \] left associative with precedence 50 for 'plus \TERM a \TERM b.
-notation \[ \TERM a * \TERM b \] left associative with precedence 60 for 'mult \TERM a \TERM b.
-interpretation 'plus x y = (cic:/Coq/Init/Peano/plus.con x y).
-interpretation 'mult x y = (cic:/Coq/Init/Peano/mult.con x y).
-render cic:/Coq/Arith/Mult/mult_plus_distr_r.con.
-
-notation \[ \LIST \NUM a \] for \FOLD left \[ 'a \] \LAMBDA acc \[ 'b \NUM a \].
-
-
+++ /dev/null
-%%
-%% This is file `semantic.sty',
-%% generated with the docstrip utility.
-%%
-%% The original source files were:
-%%
-%% semantic.dtx (with options: `general')
-%%
-%% IMPORTANT NOTICE:
-%%
-%% For the copyright see the source file.
-%%
-%% Any modified versions of this file must be renamed
-%% with new filenames distinct from semantic.sty.
-%%
-%% For distribution of the original source see the terms
-%% for copying and modification in the file semantic.dtx.
-%%
-%% This generated file may be distributed as long as the
-%% original source files, as listed above, are part of the
-%% same distribution. (The sources need not necessarily be
-%% in the same archive or directory.)
-%%
-%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and
-%% Arne John Glenstrup
-%%
-\NeedsTeXFormat{LaTeX2e}
-\newcommand{\semanticVersion}{2.0(epsilon)}
-\newcommand{\semanticDate}{2003/10/28}
-\ProvidesPackage{semantic}
- [\semanticDate\space v\semanticVersion\space]
-\typeout{Semantic Package v\semanticVersion\space [\semanticDate]}
-\typeout{CVSId: $Id$}
-\newcounter{@@conflict}
-\newcommand{\@semanticNotDefinable}{%
- \typeout{Command \@backslashchar\reserved@a\space already defined}
- \stepcounter{@@conflict}}
-\newcommand{\@oldNotDefinable}{}
-\let\@oldNotDefinable=\@notdefinable
-\let\@notdefinable=\@semanticNotDefinable
-\newcommand{\TestForConflict}{}
-\def\TestForConflict#1{\sem@test #1,,}
-\newcommand{\sem@test}{}
-\newcommand{\sem@tmp}{}
-\newcommand{\@@next}{}
-\def\sem@test#1,{%
- \def\sem@tmp{#1}%
- \ifx \sem@tmp\empty \let\@@next=\relax \else
- \@ifdefinable{#1}{} \let\@@next=\sem@test \fi
- \@@next}
-\TestForConflict{\@inputLigature,\@inputInference,\@inputTdiagram}
-\TestForConflict{\@inputReservedWords,\@inputShorthand}
-\TestForConflict{\@ddInput,\sem@nticsLoader,\lo@d}
-\def\@inputLigature{\input{ligature.sty}\message{ math mode ligatures,}%
- \let\@inputLigature\relax}
-\def\@inputInference{\input{infernce.sty}\message{ inference rules,}%
- \let\@inputInference\relax}
-\def\@inputTdiagram{\input{tdiagram.sty}\message{ T diagrams,}%
- \let\@inputTdiagram\relax}
-\def\@inputReservedWords{\input{reserved.sty}\message{ reserved words,}%
- \let\@inputReservedWords\relax}
-\def\@inputShorthand{\input{shrthand.sty}\message{ short hands,}%
- \let\@inputShorthand\relax}
-\toks1={}
-\newcommand{\@ddInput}[1]{%
- \toks1=\expandafter{\the\toks1\noexpand#1}}
-\DeclareOption{ligature}{\@ddInput\@inputLigature}
-\DeclareOption{inference}{\@ddInput\@inputInference}
-\DeclareOption{tdiagram}{\@ddInput\@inputTdiagram}
-\DeclareOption{reserved}{\@ddInput\@inputReservedWords}
-\DeclareOption{shorthand}{\@ddInput\@inputLigature
- \@ddInput\@inputShorthand}
-\ProcessOptions*
-\typeout{Loading features: }
-\def\sem@nticsLoader{}
-\edef\lo@d{\the\toks1}
-\ifx\lo@d\empty
- \@inputLigature
- \@inputInference
- \@inputTdiagram
- \@inputReservedWords
- \@inputShorthand
-\else
- \lo@d
-\fi
-\typeout{and general definitions.^^J}
-\let\@ddInput\relax
-\let\@inputInference\relax
-\let\@inputLigature\relax
-\let\@inputTdiagram\relax
-\let\@inputReservedWords\relax
-\let\@inputShorthand\relax
-\let\sem@nticsLoader\realx
-\let\lo@d\relax
-\TestForConflict{\@dropnext,\@ifnext,\@ifn,\@ifNextMacro,\@ifnMacro}
-\TestForConflict{\@@maxwidth,\@@pLineBox,\if@@Nested,\@@cBox}
-\TestForConflict{\if@@moreLines,\@@pBox}
-\def\@ifnext#1#2#3{%
- \let\reserved@e=#1\def\reserved@a{#2}\def\reserved@b{#3}\futurelet%
- \reserved@c\@ifn}
-\def\@ifn{%
- \ifx \reserved@c \reserved@e\let\reserved@d\reserved@a\else%
- \let\reserved@d\reserved@b\fi \reserved@d}
-\def\@ifNextMacro#1#2{%
- \def\reserved@a{#1}\def\reserved@b{#2}%
- \futurelet\reserved@c\@ifnMacro}
-\def\@ifnMacro{%
- \ifcat\noexpand\reserved@c\noexpand\@ifnMacro
- \let\reserved@d\reserved@a
- \else \let\reserved@d\reserved@b\fi \reserved@d}
-\newcommand{\@dropnext}[2]{#1}
-\ifnum \value{@@conflict} > 0
- \PackageError{Semantic}
- {The \the@@conflict\space command(s) listed above have been
- redefined.\MessageBreak
- Please report this to turtle@bu.edu}
- {Some of the commands defined in semantic was already defined %
- and has\MessageBreak now be redefined. There is a risk that %
- these commands will be used\MessageBreak by other packages %
- leading to spurious errors.\MessageBreak
- \space\space Type <return> and cross your fingers%
-}\fi
-\let\@notdefinable=\@oldNotDefinable
-\let\@semanticNotDefinable=\relax
-\let\@oldNotDefinable=\relax
-\let\TestForConflict=\relax
-\let\@endmark=\relax
-\let\sem@test=\relax
-\newdimen\@@maxwidth
-\newbox\@@pLineBox
-\newbox\@@cBox
-\newbox\@@pBox
-\newif\if@@moreLines
-\newif\if@@Nested \@@Nestedfalse
-\endinput
-%%
-%% End of file `semantic.sty'.
+++ /dev/null
-%%
-%% This is file `shrthand.sty',
-%% generated with the docstrip utility.
-%%
-%% The original source files were:
-%%
-%% semantic.dtx (with options: `allOptions,shorthand')
-%%
-%% IMPORTANT NOTICE:
-%%
-%% For the copyright see the source file.
-%%
-%% Any modified versions of this file must be renamed
-%% with new filenames distinct from shrthand.sty.
-%%
-%% For distribution of the original source see the terms
-%% for copying and modification in the file semantic.dtx.
-%%
-%% This generated file may be distributed as long as the
-%% original source files, as listed above, are part of the
-%% same distribution. (The sources need not necessarily be
-%% in the same archive or directory.)
-%%
-%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and
-%% Arne John Glenstrup
-%%
-\expandafter\ifx\csname sem@nticsLoader\endcsname\relax
- \PackageError{semantic}{%
- This file should not be loaded directly}
- {%
- This file is an option of the semantic package. It should not be
- loaded directly\MessageBreak
- but by using \protect\usepackage{semantic} in your document
- preamble.\MessageBreak
- No commands are defined.\MessageBreak
- Type <return> to proceed.
- }%
-\else
-\IfFileExists{DONOTUSEmathbbol.sty}{%
- \RequirePackage{mathbbol}
- \newcommand{\@bblb}{\textbb{[}}
- \newcommand{\@bbrb}{\textbb{]}}
- \newcommand{\@mbblb}{\mathopen{\mbox{\textbb{[}}}}
- \newcommand{\@mbbrb}{\mathclose{\mbox{\textbb{]}}}}
-}
-{ \newcommand{\@bblb}{\textnormal{[\kern-.15em[}}
- \newcommand{\@bbrb}{\textnormal{]\kern-.15em]}}
- \newcommand{\@mbblb}{\mathopen{[\mkern-2.67mu[}}
- \newcommand{\@mbbrb}{\mathclose{]\mkern-2.67mu]}}
-}
-\mathlig{|-}{\vdash}
-\mathlig{|=}{\models}
-\mathlig{->}{\rightarrow}
-\mathlig{->*}{\mathrel{\rightarrow^*}}
-\mathlig{->+}{\mathrel{\rightarrow^+}}
-\mathlig{-->}{\longrightarrow}
-\mathlig{-->*}{\mathrel{\longrightarrow^*}}
-\mathlig{-->+}{\mathrel{\longrightarrow^+}}
-\mathlig{=>}{\Rightarrow}
-\mathlig{=>*}{\mathrel{\Rightarrow^*}}
-\mathlig{=>+}{\mathrel{\Rightarrow^+}}
-\mathlig{==>}{\Longrightarrow}
-\mathlig{==>*}{\mathrel{\Longrightarrow^*}}
-\mathlig{==>+}{\mathrel{\Longrightarrow^+}}
-\mathlig{<-}{\leftarrow}
-\mathlig{*<-}{\mathrel{{}^*\mkern-1mu\mathord\leftarrow}}
-\mathlig{+<-}{\mathrel{{}^+\mkern-1mu\mathord\leftarrow}}
-\mathlig{<--}{\longleftarrow}
-\mathlig{*<--}{\mathrel{{}^*\mkern-1mu\mathord{\longleftarrow}}}
-\mathlig{+<--}{\mathrel{{}^+\mkern-1mu\mathord{\longleftarrow}}}
-\mathlig{<=}{\Leftarrow}
-\mathlig{*<=}{\mathrel{{}^*\mkern-1mu\mathord\Leftarrow}}
-\mathlig{+<=}{\mathrel{{}^+\mkern-1mu\mathord\Leftarrow}}
-\mathlig{<==}{\Longleftarrow}
-\mathlig{*<==}{\mathrel{{}^*\mkern-1mu\mathord{\Longleftarrow}}}
-\mathlig{+<==}{\mathrel{{}^+\mkern-1mu\mathord{\Longleftarrow}}}
-\mathlig{<->}{\longleftrightarrow}
-\mathlig{<=>}{\Longleftrightarrow}
-\mathlig{|[}{\@mbblb}
-\mathlig{|]}{\@mbbrb}
-\newcommand{\evalsymbol}[1][]{\ensuremath{\mathcal{E}^{#1}}}
-\newcommand{\compsymbol}[1][]{\ensuremath{\mathcal{C}^{#1}}}
-\newcommand{\eval}[3][]%
- {\mbox{$\mathcal{E}^{#1}$\@bblb \texttt{#2}\@bbrb}%
- \ensuremath{\mathtt{#3}}}
-\newcommand{\comp}[3][]%
- {\mbox{$\mathcal{C}^{#1}$\@bblb \texttt{#2}\@bbrb}%
- \ensuremath{\mathtt{#3}}}
-\newcommand{\@exe}[3]{}
-\newcommand{\exe}[1]{\@ifnextchar[{\@exe{#1}}{\@exe{#1}[]}}
-\def\@exe#1[#2]#3{%
- \mbox{\@bblb\texttt{#1}\@bbrb$^\mathtt{#2}\mathtt{(#3)}$}}
-\fi
-\endinput
-%%
-%% End of file `shrthand.sty'.
+++ /dev/null
-%%
-%% This is file `tdiagram.sty',
-%% generated with the docstrip utility.
-%%
-%% The original source files were:
-%%
-%% semantic.dtx (with options: `allOptions,Tdiagram')
-%%
-%% IMPORTANT NOTICE:
-%%
-%% For the copyright see the source file.
-%%
-%% Any modified versions of this file must be renamed
-%% with new filenames distinct from tdiagram.sty.
-%%
-%% For distribution of the original source see the terms
-%% for copying and modification in the file semantic.dtx.
-%%
-%% This generated file may be distributed as long as the
-%% original source files, as listed above, are part of the
-%% same distribution. (The sources need not necessarily be
-%% in the same archive or directory.)
-%%
-%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and
-%% Arne John Glenstrup
-%%
-\expandafter\ifx\csname sem@nticsLoader\endcsname\relax
- \PackageError{semantic}{%
- This file should not be loaded directly}
- {%
- This file is an option of the semantic package. It should not be
- loaded directly\MessageBreak
- but by using \protect\usepackage{semantic} in your document
- preamble.\MessageBreak
- No commands are defined.\MessageBreak
- Type <return> to proceed.
- }%
-\else
-\TestForConflict{\@getSymbol,\@interpreter,\@parseArg,\@program}
-\TestForConflict{\@putSymbol,\@saveBeforeSymbolMacro,\compiler}
-\TestForConflict{\interpreter,\machine,\program,\@compiler}
-\newif\if@@Left
-\newif\if@@Up
-\newcount\@@xShift
-\newcount\@@yShift
-\newtoks\@@symbol
-\newtoks\@@tempSymbol
-\newcommand{\compiler}[1]{\@compiler#1\end}
-\def\@compiler#1,#2,#3\end{%
- \if@@Nested %
- \if@@Up %
- \@@yShift=40 \if@@Left \@@xShift=-50 \else \@@xShift=-30 \fi
- \else%
- \@@yShift=20 \@@xShift =0 %
- \fi%
- \else%
- \@@yShift=40 \@@xShift=-40%
- \fi
- \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{%
- \put(0,0){\line(1,0){80}}%
- \put(0,-20){\line(1,0){30}}%
- \put(50,-20){\line(1,0){30}}%
- \put(30,-40){\line(1,0){20}}%
- \put(0,0){\line(0,-1){20}}%
- \put(80,0){\line(0,-1){20}}%
- \put(30,-20){\line(0,-1){20}}%
- \put(50,-20){\line(0,-1){20}}%
- \put(30,-20){\makebox(20,20){$\rightarrow$}} %
- {\@@Uptrue \@@Lefttrue \@parseArg(0,-20)(5,-20)#1\end}%
- \if@@Up \else \@@tempSymbol=\expandafter{\the\@@symbol}\fi
- {\@@Uptrue \@@Leftfalse \@parseArg(80,-20)(55,-20)#3\end}%
- {\@@Upfalse \@@Lefttrue \@parseArg(50,-40)(30,-40)#2\end}%
- \if@@Up \@@tempSymbol=\expandafter{\the\@@symbol}\fi
- \if@@Nested \global\@@symbol=\expandafter{\the\@@tempSymbol} \fi%
- }%
-}
-\newcommand{\interpreter}[1]{\@interpreter#1\end}
-\def\@interpreter#1,#2\end{%
- \if@@Nested %
- \if@@Up %
- \@@yShift=40 \if@@Left \@@xShift=0 \else \@@xShift=20 \fi
- \else%
- \@@yShift=0 \@@xShift =0 %
- \fi%
- \else%
- \@@yShift=40 \@@xShift=10%
- \fi
- \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{%
- \put(0,0){\line(-1,0){20}}%
- \put(0,-40){\line(-1,0){20}}%
- \put(0,0){\line(0,-1){40}}%
- \put(-20,0){\line(0,-1){40}}%
- {\@@Uptrue \@@Lefttrue \@parseArg(0,0)(-20,-20)#1\end}%
- \if@@Up \else \@@tempSymbol=\expandafter{\the\@@symbol}\fi
- {\@@Upfalse \@@Lefttrue \@parseArg(0,-40)(-20,-40)#2\end}%
- \if@@Up \@@tempSymbol=\expandafter{\the\@@symbol}\fi
- \if@@Nested \global\@@symbol=\expandafter{\the\@@tempSymbol} \fi%
- }%
-}
-\newcommand{\program}[1]{\@program#1\end}
-\def\@program#1,#2\end{%
- \if@@Nested %
- \if@@Up %
- \@@yShift=0 \if@@Left \@@xShift=0 \else \@@xShift=20 \fi
- \else%
- \PackageError{semantic}{%
- A program cannot be at the bottom}
- {%
- You have tried to use a \protect\program\space as the
- bottom\MessageBreak parameter to \protect\compiler,
- \protect\interpreter\space or \protect\program.\MessageBreak
- Type <return> to proceed --- Output can be distorted.}%
- \fi%
- \else%
- \@@yShift=0 \@@xShift=10%
- \fi
- \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{%
- \put(0,0){\line(-1,0){20}}%
- \put(0,0){\line(0,1){30}}%
- \put(-20,0){\line(0,1){30}}%
- \put(-10,30){\oval(20,20)[t]}%
- \@putSymbol[#1]{-20,20}%
- {\@@Upfalse \@@Lefttrue \@parseArg(0,0)(-20,0)#2\end}%
- }%
-}
-\newcommand{\machine}[1]{%
- \if@@Nested %
- \if@@Up %
- \PackageError{semantic}{%
- A machine cannot be at the top}
- {%
- You have tried to use a \protect\machine\space as a
- top\MessageBreak parameter to \protect\compiler or
- \protect\interpreter.\MessageBreak
- Type <return> to proceed --- Output can be distorted.}%
- \else \@@yShift=0 \@@xShift=0
- \fi%
- \else%
- \@@yShift=20 \@@xShift=10%
- \fi
- \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{%
- \put(0,0){\line(-1,0){20}} \put(-20,0){\line(3,-5){10}}
- \put(0,0){\line(-3,-5){10}}%
- {\@@Uptrue \@@Lefttrue \@parseArg(0,0)(-20,-15)#1\end}%
- }%
-}
-\def\@parseArg(#1)(#2){%
- \@ifNextMacro{\@doSymbolMacro(#1)(#2)}{\@getSymbol(#2)}}
-\def\@getSymbol(#1)#2\end{\@putSymbol[#2]{#1}}
-\def\@doSymbolMacro(#1)(#2)#3{%
- \@ifnextchar[{\@saveBeforeSymbolMacro(#1)(#2)#3}%
- {\@symbolMacro(#1)(#2)#3}}
-\def\@saveBeforeSymbolMacro(#1)(#2)#3[#4]#5\end{%
- \@@tempSymbol={#4}%
- \@@Nestedtrue\put(#1){#3#5}%
- \@putSymbol[\the\@@tempSymbol]{#2}}
-\def\@symbolMacro(#1)(#2)#3\end{%
- \@@Nestedtrue\put(#1){#3}%
- \@putSymbol{#2}}
-\newcommand{\@putSymbol}[2][\the\@@symbol]{%
- \global\@@symbol=\expandafter{#1}%
- \put(#2){\makebox(20,20){\texttt{\the\@@symbol}}}}
-\fi
-\endinput
-%%
-%% End of file `tdiagram.sty'.
+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-module Ast = CicNotationPt
-
-type direction = [ `LeftToRight | `RightToLeft ]
-
-type loc = Ast.location
-
-type ('term, 'lazy_term, 'ident) pattern =
- 'lazy_term option * ('ident * 'term) list * 'term
-
-type ('term, 'ident) type_spec =
- | Ident of 'ident
- | Type of UriManager.uri * int
-
-type reduction =
- [ `Normalize
- | `Reduce
- | `Simpl
- | `Unfold of CicNotationPt.term option
- | `Whd ]
-
-type ('term, 'lazy_term, 'reduction, 'ident) tactic =
- | Absurd of loc * 'term
- | Apply of loc * 'term
- | Assumption of loc
- | Auto of loc * int option * int option * string option * string option
- (* depth, width, paramodulation, full *) (* ALB *)
- | Change of loc * ('term, 'lazy_term, 'ident) pattern * 'lazy_term
- | Clear of loc * 'ident
- | ClearBody of loc * 'ident
- | Compare of loc * 'term
- | Constructor of loc * int
- | Contradiction of loc
- | Cut of loc * 'ident option * 'term
- | DecideEquality of loc
- | Decompose of loc * ('term, 'ident) type_spec list * 'ident * 'ident list
- | Discriminate of loc * 'term
- | Elim of loc * 'term * 'term option * int option * 'ident list
- | ElimType of loc * 'term * 'term option * int option * 'ident list
- | Exact of loc * 'term
- | Exists of loc
- | Fail of loc
- | Fold of loc * 'reduction * 'lazy_term * ('term, 'lazy_term, 'ident) pattern
- | Fourier of loc
- | FwdSimpl of loc * string * 'ident list
- | Generalize of loc * ('term, 'lazy_term, 'ident) pattern * 'ident option
- | Goal of loc * int (* change current goal, argument is goal number 1-based *)
- | IdTac of loc
- | Injection of loc * 'term
- | Intros of loc * int option * 'ident list
- | LApply of loc * int option * 'term list * 'term * 'ident option
- | Left of loc
- | LetIn of loc * 'term * 'ident
- | Reduce of loc * 'reduction * ('term, 'lazy_term, 'ident) pattern
- | Reflexivity of loc
- | Replace of loc * ('term, 'lazy_term, 'ident) pattern * 'lazy_term
- | Rewrite of loc * direction * 'term *
- ('term, 'lazy_term, 'ident) pattern
- | Right of loc
- | Ring of loc
- | Split of loc
- | Symmetry of loc
- | Transitivity of loc * 'term
-
-type thm_flavour = Cic.object_flavour
-
- (** <name, inductive/coinductive, type, constructor list>
- * true means inductive, false coinductive *)
-type 'term inductive_type = string * bool * 'term * (string * 'term) list
-
-type search_kind = [ `Locate | `Hint | `Match | `Elim ]
-
-type print_kind = [ `Env | `Coer ]
-
-type 'term macro =
- (* Whelp's stuff *)
- | WHint of loc * 'term
- | WMatch of loc * 'term
- | WInstance of loc * 'term
- | WLocate of loc * string
- | WElim of loc * 'term
- (* real macros *)
-(* | Abort of loc *)
- | Print of loc * string
- | Check of loc * 'term
- | Hint of loc
- | Quit of loc
-(* | Redo of loc * int option
- | Undo of loc * int option *)
-(* | Print of loc * print_kind *)
- | Search_pat of loc * search_kind * string (* searches with string pattern *)
- | Search_term of loc * search_kind * 'term (* searches with term pattern *)
-
-type alias_spec =
- | Ident_alias of string * string (* identifier, uri *)
- | Symbol_alias of string * int * string (* name, instance no, description *)
- | Number_alias of int * string (* instance no, description *)
-
-type obj =
- | Inductive of (string * Ast.term) list *
- Ast.term inductive_type list
- (** parameters, list of loc * mutual inductive types *)
- | Theorem of thm_flavour * string * Ast.term * Ast.term option
- (** flavour, name, type, body
- * - name is absent when an unnamed theorem is being proved, tipically in
- * interactive usage
- * - body is present when its given along with the command, otherwise it
- * will be given in proof editing mode using the tactical language
- *)
- | Record of (string * Ast.term) list * string * Ast.term *
- (string * Ast.term) list
- (** left parameters, name, type, fields *)
-
-type metadata =
- | Dependency of string (* baseuri without trailing slash *)
- | Baseuri of string
-
-let compare_metadata = Pervasives.compare
-
-let eq_metadata = (=)
-
-(** To be increased each time the command type below changes, used for "safe"
- * marshalling *)
-let magic = 2
-
-type ('term,'obj) command =
- | Default of loc * string * UriManager.uri list
- | Include of loc * string
- | Set of loc * string * string
- | Drop of loc
- | Qed of loc
- (** name.
- * Name is needed when theorem was started without providing a name
- *)
- | Coercion of loc * 'term
- | Alias of loc * alias_spec
- (** parameters, name, type, fields *)
- | Obj of loc * 'obj
- | Notation of loc * direction option * Ast.term * Gramext.g_assoc *
- int * Ast.term
- (* direction, l1 pattern, associativity, precedence, l2 pattern *)
- | Interpretation of loc *
- string * (string * Ast.argument_pattern list) *
- Ast.cic_appl_pattern
- (* description (i.e. id), symbol, arg pattern, appl pattern *)
-
- | Metadata of loc * metadata
-
- (* DEBUGGING *)
- | Dump of loc (* dump grammar on stdout *)
- (* DEBUGGING *)
- | Render of loc * UriManager.uri (* render library object *)
-
-(* composed magic: term + command magics. No need to change this value *)
-let magic = magic + 10000 * CicNotationPt.magic
-
-let reash_cmd_uris =
- let reash_uri uri = UriManager.uri_of_string (UriManager.string_of_uri uri) in
- function
- | Default (loc, name, uris) ->
- let uris = List.map reash_uri uris in
- Default (loc, name, uris)
- | Interpretation (loc, dsc, args, cic_appl_pattern) ->
- let rec aux =
- function
- | CicNotationPt.UriPattern uri ->
- CicNotationPt.UriPattern (reash_uri uri)
- | CicNotationPt.ApplPattern args ->
- CicNotationPt.ApplPattern (List.map aux args)
- | CicNotationPt.VarPattern _
- | CicNotationPt.ImplicitPattern as pat -> pat
- in
- let appl_pattern = aux cic_appl_pattern in
- Interpretation (loc, dsc, args, appl_pattern)
- | cmd -> cmd
-
-type ('term, 'lazy_term, 'reduction, 'ident) tactical =
- | Tactic of loc * ('term, 'lazy_term, 'reduction, 'ident) tactic
- | Do of loc * int * ('term, 'lazy_term, 'reduction, 'ident) tactical
- | Repeat of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical
- | Seq of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list
- (* sequential composition *)
- | Then of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical *
- ('term, 'lazy_term, 'reduction, 'ident) tactical list
- | First of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list
- (* try a sequence of loc * tactical until one succeeds, fail otherwise *)
- | Try of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical
- (* try a tactical and mask failures *)
- | Solve of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list
-
- | Dot of loc
- | Semicolon of loc
- | Branch of loc
- | Shift of loc
- | Pos of loc * int
- | Merge of loc
- | Focus of loc * int list
- | Unfocus of loc
- | Skip of loc
-
-let is_punctuation =
- function
- | Dot _ | Semicolon _ | Branch _ | Shift _ | Merge _ | Pos _ -> true
- | _ -> false
-
-type ('term, 'lazy_term, 'reduction, 'obj, 'ident) code =
- | Command of loc * ('term,'obj) command
- | Macro of loc * 'term macro
- | Tactical of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical
- * ('term, 'lazy_term, 'reduction, 'ident) tactical option(* punctuation *)
-
-type ('term, 'lazy_term, 'reduction, 'obj, 'ident) comment =
- | Note of loc * string
- | Code of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) code
-
-type ('term, 'lazy_term, 'reduction, 'obj, 'ident) statement =
- | Executable of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) code
- | Comment of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) comment
-
- (* statements meaningful for matitadep *)
-type dependency =
- | IncludeDep of string
- | BaseuriDep of string
- | UriDep of UriManager.uri
-
+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Printf
-
-open GrafiteAst
-
-module Ast = CicNotationPt
-
-let tactical_terminator = ""
-let tactic_terminator = tactical_terminator
-let command_terminator = tactical_terminator
-
-let pp_term_ast term = CicNotationPp.pp_term term
-let pp_term_cic term = CicPp.ppterm term
-
-let pp_idents idents = "[" ^ String.concat "; " idents ^ "]"
-
-let pp_terms_ast terms = String.concat ", " (List.map pp_term_ast terms)
-
-let pp_reduction_kind = function
- | `Normalize -> "normalize"
- | `Reduce -> "reduce"
- | `Simpl -> "simplify"
- | `Unfold (Some t) -> "unfold " ^ pp_term_ast t
- | `Unfold None -> "unfold"
- | `Whd -> "whd"
-
-
-let pp_pattern (t, hyp, goal) =
- let pp_hyp_pattern l =
- String.concat "; "
- (List.map (fun (name, p) -> sprintf "%s : %s" name (pp_term_ast p)) l) in
- let pp_t t =
- match t with
- None -> ""
- | Some t -> pp_term_ast t
- in
- pp_t t ^ " in " ^ pp_hyp_pattern hyp ^ " \\vdash " ^ pp_term_ast goal
-
-let pp_intros_specs = function
- | None, [] -> ""
- | Some num, [] -> Printf.sprintf " names %i" num
- | None, idents -> Printf.sprintf " names %s" (pp_idents idents)
- | Some num, idents -> Printf.sprintf " names %i %s" num (pp_idents idents)
-
-let rec pp_tactic = function
- | Absurd (_, term) -> "absurd" ^ pp_term_ast term
- | Apply (_, term) -> "apply " ^ pp_term_ast term
- | Auto _ -> "auto"
- | Assumption _ -> "assumption"
- | Change (_, where, with_what) ->
- sprintf "change %s with %s" (pp_pattern where) (pp_term_ast with_what)
- | Clear (_,id) -> sprintf "clear %s" id
- | ClearBody (_,id) -> sprintf "clearbody %s" id
- | Compare (_,term) -> "compare " ^ pp_term_ast term
- | Constructor (_,n) -> "constructor " ^ string_of_int n
- | Contradiction _ -> "contradiction"
- | Cut (_, ident, term) ->
- "cut " ^ pp_term_ast term ^
- (match ident with None -> "" | Some id -> " as " ^ id)
- | DecideEquality _ -> "decide equality"
- | Decompose (_, [], what, names) ->
- sprintf "decompose %s%s" what (pp_intros_specs (None, names))
- | Decompose (_, types, what, names) ->
- let to_ident = function
- | Ident id -> id
- | Type _ -> assert false
- in
- let types = List.rev_map to_ident types in
- sprintf "decompose %s %s%s" (pp_idents types) what (pp_intros_specs (None, names))
- | Discriminate (_, term) -> "discriminate " ^ pp_term_ast term
- | Elim (_, term, using, num, idents) ->
- sprintf "elim " ^ pp_term_ast term ^
- (match using with None -> "" | Some term -> " using " ^ pp_term_ast term)
- ^ pp_intros_specs (num, idents)
- | ElimType (_, term, using, num, idents) ->
- sprintf "elim type " ^ pp_term_ast term ^
- (match using with None -> "" | Some term -> " using " ^ pp_term_ast term)
- ^ pp_intros_specs (num, idents)
- | Exact (_, term) -> "exact " ^ pp_term_ast term
- | Exists _ -> "exists"
- | Fold (_, kind, term, pattern) ->
- sprintf "fold %s %s %s" (pp_reduction_kind kind)
- (pp_term_ast term) (pp_pattern pattern)
- | FwdSimpl (_, hyp, idents) ->
- sprintf "fwd %s%s" hyp
- (match idents with [] -> "" | idents -> " " ^ pp_idents idents)
- | Generalize (_, pattern, ident) ->
- sprintf "generalize %s%s" (pp_pattern pattern)
- (match ident with None -> "" | Some id -> " as " ^ id)
- | Goal (_, n) -> "goal " ^ string_of_int n
- | Fail _ -> "fail"
- | Fourier _ -> "fourier"
- | IdTac _ -> "id"
- | Injection (_, term) -> "injection " ^ pp_term_ast term
- | Intros (_, None, []) -> "intro"
- | Intros (_, num, idents) ->
- sprintf "intros%s%s"
- (match num with None -> "" | Some num -> " " ^ string_of_int num)
- (match idents with [] -> "" | idents -> " " ^ pp_idents idents)
- | LApply (_, level_opt, terms, term, ident_opt) ->
- sprintf "lapply %s%s%s%s"
- (match level_opt with None -> "" | Some i -> " depth = " ^ string_of_int i ^ " ")
- (pp_term_ast term)
- (match terms with [] -> "" | _ -> " to " ^ pp_terms_ast terms)
- (match ident_opt with None -> "" | Some ident -> " using " ^ ident)
- | Left _ -> "left"
- | LetIn (_, term, ident) -> sprintf "let %s in %s" (pp_term_ast term) ident
- | Reduce (_, kind, pat) ->
- sprintf "%s %s" (pp_reduction_kind kind) (pp_pattern pat)
- | Reflexivity _ -> "reflexivity"
- | Replace (_, pattern, t) ->
- sprintf "replace %s with %s" (pp_pattern pattern) (pp_term_ast t)
- | Rewrite (_, pos, t, pattern) ->
- sprintf "rewrite %s %s %s"
- (if pos = `LeftToRight then ">" else "<")
- (pp_term_ast t)
- (pp_pattern pattern)
- | Right _ -> "right"
- | Ring _ -> "ring"
- | Split _ -> "split"
- | Symmetry _ -> "symmetry"
- | Transitivity (_, term) -> "transitivity " ^ pp_term_ast term
-
-let pp_flavour = function
- | `Definition -> "Definition"
- | `Fact -> "Fact"
- | `Goal -> "Goal"
- | `Lemma -> "Lemma"
- | `Remark -> "Remark"
- | `Theorem -> "Theorem"
- | `Variant -> "Variant"
-
-let pp_search_kind = function
- | `Locate -> "locate"
- | `Hint -> "hint"
- | `Match -> "match"
- | `Elim -> "elim"
- | `Instance -> "instance"
-
-let pp_macro pp_term = function
- (* Whelp *)
- | WInstance (_, term) -> "whelp instance " ^ pp_term term
- | WHint (_, t) -> "whelp hint " ^ pp_term t
- | WLocate (_, s) -> "whelp locate " ^ s
- | WElim (_, t) -> "whelp elim " ^ pp_term t
- | WMatch (_, term) -> "whelp match " ^ pp_term term
- (* real macros *)
-(* | Abort _ -> "Abort" *)
- | Check (_, term) -> sprintf "Check %s" (pp_term term)
- | Hint _ -> "hint"
-(* | Redo (_, None) -> "Redo"
- | Redo (_, Some n) -> sprintf "Redo %d" n *)
- | Search_pat (_, kind, pat) ->
- sprintf "search %s \"%s\"" (pp_search_kind kind) pat
- | Search_term (_, kind, term) ->
- sprintf "search %s %s" (pp_search_kind kind) (pp_term term)
-(* | Undo (_, None) -> "Undo"
- | Undo (_, Some n) -> sprintf "Undo %d" n *)
- | Print (_, name) -> sprintf "Print \"%s\"" name
- | Quit _ -> "Quit"
-
-let pp_macro_ast = pp_macro pp_term_ast
-let pp_macro_cic = pp_macro pp_term_cic
-
-let pp_alias = function
- | Ident_alias (id, uri) -> sprintf "alias id \"%s\" = \"%s\"" id uri
- | Symbol_alias (symb, instance, desc) ->
- sprintf "alias symbol \"%s\" (instance %d) = \"%s\""
- symb instance desc
- | Number_alias (instance,desc) ->
- sprintf "alias num (instance %d) = \"%s\"" instance desc
-
-let pp_params = function
- | [] -> ""
- | params ->
- " " ^
- String.concat " "
- (List.map
- (fun (name, typ) -> sprintf "(%s:%s)" name (pp_term_ast typ))
- params)
-
-let pp_fields fields =
- (if fields <> [] then "\n" else "") ^
- String.concat ";\n"
- (List.map (fun (name,ty) -> " " ^ name ^ ": " ^ pp_term_ast ty) fields)
-
-let pp_obj = function
- | Inductive (params, types) ->
- let pp_constructors constructors =
- String.concat "\n"
- (List.map (fun (name, typ) -> sprintf "| %s: %s" name (pp_term_ast typ))
- constructors)
- in
- let pp_type (name, _, typ, constructors) =
- sprintf "\nwith %s: %s \\def\n%s" name (pp_term_ast typ)
- (pp_constructors constructors)
- in
- (match types with
- | [] -> assert false
- | (name, inductive, typ, constructors) :: tl ->
- let fst_typ_pp =
- sprintf "%sinductive %s%s: %s \\def\n%s"
- (if inductive then "" else "co") name (pp_params params)
- (pp_term_ast typ) (pp_constructors constructors)
- in
- fst_typ_pp ^ String.concat "" (List.map pp_type tl))
- | Theorem (flavour, name, typ, body) ->
- sprintf "%s %s: %s %s"
- (pp_flavour flavour)
- name
- (pp_term_ast typ)
- (match body with
- | None -> ""
- | Some body -> "\\def " ^ pp_term_ast body)
- | Record (params,name,ty,fields) ->
- "record " ^ name ^ " " ^ pp_params params ^ " \\def {" ^
- pp_fields fields ^ "}"
-
-let pp_argument_pattern = function
- | Ast.IdentArg (eta_depth, name) ->
- let eta_buf = Buffer.create 5 in
- for i = 1 to eta_depth do
- Buffer.add_string eta_buf "\\eta."
- done;
- sprintf "%s%s" (Buffer.contents eta_buf) name
-
-let rec pp_cic_appl_pattern = function
- | Ast.UriPattern uri -> UriManager.string_of_uri uri
- | Ast.VarPattern name -> name
- | Ast.ImplicitPattern -> "_"
- | Ast.ApplPattern aps ->
- sprintf "(%s)" (String.concat " " (List.map pp_cic_appl_pattern aps))
-
-let pp_l1_pattern = CicNotationPp.pp_term
-let pp_l2_pattern = CicNotationPp.pp_term
-
-let pp_associativity = function
- | Gramext.LeftA -> "left associative"
- | Gramext.RightA -> "right associative"
- | Gramext.NonA -> "non associative"
-
-let pp_precedence i = sprintf "with precedence %d" i
-
-let pp_dir_opt = function
- | None -> ""
- | Some `LeftToRight -> "> "
- | Some `RightToLeft -> "< "
-
-let pp_metadata =
- function
- | Dependency buri -> sprintf "dependency %s" buri
- | Baseuri buri -> sprintf "baseuri %s" buri
-
-let pp_command = function
- | Include (_,path) -> "include " ^ path
- | Qed _ -> "qed"
- | Drop _ -> "drop"
- | Set (_, name, value) -> sprintf "set \"%s\" \"%s\"" name value
- | Coercion (_,term) -> sprintf "coercion %s" (pp_term_ast term)
- | Alias (_,s) -> pp_alias s
- | Obj (_,obj) -> pp_obj obj
- | Default (_,what,uris) ->
- sprintf "default \"%s\" %s" what
- (String.concat " " (List.map UriManager.string_of_uri uris))
- | Interpretation (_, dsc, (symbol, arg_patterns), cic_appl_pattern) ->
- sprintf "interpretation \"%s\" '%s %s = %s"
- dsc symbol
- (String.concat " " (List.map pp_argument_pattern arg_patterns))
- (pp_cic_appl_pattern cic_appl_pattern)
- | Notation (_, dir_opt, l1_pattern, assoc, prec, l2_pattern) ->
- sprintf "notation %s\"%s\" %s %s for %s"
- (pp_dir_opt dir_opt)
- (pp_l1_pattern l1_pattern)
- (pp_associativity assoc)
- (pp_precedence prec)
- (pp_l2_pattern l2_pattern)
- | Metadata (_, m) -> sprintf "metadata %s" (pp_metadata m)
- | Render _
- | Dump _ -> assert false (* ZACK: debugging *)
-
-let rec pp_tactical = function
- | Tactic (_, tac) -> pp_tactic tac
- | Do (_, count, tac) -> sprintf "do %d %s" count (pp_tactical tac)
- | Repeat (_, tac) -> "repeat " ^ pp_tactical tac
- | Seq (_, tacs) -> pp_tacticals ~sep:"; " tacs
- | Then (_, tac, tacs) ->
- sprintf "%s; [%s]" (pp_tactical tac) (pp_tacticals ~sep:" | " tacs)
- | First (_, tacs) -> sprintf "tries [%s]" (pp_tacticals ~sep:" | " tacs)
- | Try (_, tac) -> "try " ^ pp_tactical tac
- | Solve (_, tac) -> sprintf "solve [%s]" (pp_tacticals ~sep:" | " tac)
-
- | Dot _ -> "."
- | Semicolon _ -> ";"
- | Branch _ -> "["
- | Shift _ -> "|"
- | Pos (_, i) -> sprintf "%d:" i
- | Merge _ -> "]"
- | Focus (_, goals) ->
- sprintf "focus %s" (String.concat " " (List.map string_of_int goals))
- | Unfocus _ -> "unfocus"
- | Skip _ -> "skip"
-
-and pp_tacticals ~sep tacs = String.concat sep (List.map pp_tactical tacs)
-
-let pp_tactical tac = pp_tactical tac
-let pp_tactic tac = pp_tactic tac
-let pp_command tac = pp_command tac
-
-let pp_executable = function
- | Macro (_,x) -> pp_macro_ast x
- | Tactical (_, tac, Some punct) -> pp_tactical tac ^ pp_tactical punct
- | Tactical (_, tac, None) -> pp_tactical tac
- | Command (_,x) -> pp_command x
-
-let pp_comment = function
- | Note (_,str) -> sprintf "(* %s *)" str
- | Code (_,code) -> sprintf "(** %s. **)" (pp_executable code)
-
-let pp_statement = function
- | Executable (_, ex) -> pp_executable ex
- | Comment (_, c) -> pp_comment c
-
-let pp_cic_command = function
- | Include (_,path) -> "include " ^ path
- | Qed _ -> "qed"
- | Drop _ -> "drop"
- | Coercion (_,term) -> sprintf "coercion %s" (CicPp.ppterm term)
- | Set _
- | Alias _
- | Default _
- | Render _
- | Dump _
- | Interpretation _
- | Metadata _
- | Notation _
- | Obj _ -> assert false (* not implemented *)
-
-let pp_dependency = function
- | IncludeDep str -> "include \"" ^ str ^ "\""
- | BaseuriDep str -> "set \"baseuri\" \"" ^ str ^ "\""
- | UriDep uri -> "uri \"" ^ UriManager.string_of_uri uri ^ "\""
-
+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-val pp_tactic:
- (CicNotationPt.term, CicNotationPt.term, GrafiteAst.reduction, string)
- GrafiteAst.tactic ->
- string
-
-val pp_obj: GrafiteAst.obj -> string
-val pp_command: (CicNotationPt.term,GrafiteAst.obj) GrafiteAst.command -> string
-val pp_metadata: GrafiteAst.metadata -> string
-val pp_macro: ('a -> string) -> 'a GrafiteAst.macro -> string
-
-val pp_comment:
- (CicNotationPt.term, CicNotationPt.term, GrafiteAst.reduction, GrafiteAst.obj,
- string)
- GrafiteAst.comment ->
- string
-
-val pp_executable:
- (CicNotationPt.term, CicNotationPt.term, GrafiteAst.reduction, GrafiteAst.obj,
- string)
- GrafiteAst.code ->
- string
-
-val pp_statement:
- (CicNotationPt.term, CicNotationPt.term, GrafiteAst.reduction, GrafiteAst.obj,
- string)
- GrafiteAst.statement ->
- string
-
-val pp_macro_ast: CicNotationPt.term GrafiteAst.macro -> string
-val pp_macro_cic: Cic.term GrafiteAst.macro -> string
-
-val pp_tactical:
- (CicNotationPt.term, CicNotationPt.term, GrafiteAst.reduction, string)
- GrafiteAst.tactical ->
- string
-
-val pp_alias: GrafiteAst.alias_spec -> string
-
-val pp_cic_command: (Cic.term,Cic.obj) GrafiteAst.command -> string
-
-val pp_dependency: GrafiteAst.dependency -> string
-
-val pp_cic_appl_pattern: CicNotationPt.cic_appl_pattern -> string
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Printf
-
-module Ast = CicNotationPt
-
-type statement =
- (CicNotationPt.term, CicNotationPt.term, GrafiteAst.reduction,
- GrafiteAst.obj, string)
- GrafiteAst.statement
-
-let grammar = CicNotationParser.level2_ast_grammar
-
-let term = CicNotationParser.term
-let statement = Grammar.Entry.create grammar "statement"
-
-let add_raw_attribute ~text t = Ast.AttributedTerm (`Raw text, t)
-
-let default_precedence = 50
-let default_associativity = Gramext.NonA
-
-EXTEND
- GLOBAL: term statement;
- arg: [
- [ LPAREN; names = LIST1 IDENT SEP SYMBOL ",";
- SYMBOL ":"; ty = term; RPAREN -> names,ty
- | name = IDENT -> [name],Ast.Implicit
- ]
- ];
- constructor: [ [ name = IDENT; SYMBOL ":"; typ = term -> (name, typ) ] ];
- tactic_term: [ [ t = term LEVEL "90N" -> t ] ];
- ident_list0: [ [ LPAREN; idents = LIST0 IDENT; RPAREN -> idents ] ];
- tactic_term_list1: [
- [ tactic_terms = LIST1 tactic_term SEP SYMBOL "," -> tactic_terms ]
- ];
- reduction_kind: [
- [ IDENT "normalize" -> `Normalize
- | IDENT "reduce" -> `Reduce
- | IDENT "simplify" -> `Simpl
- | IDENT "unfold"; t = OPT term -> `Unfold t
- | IDENT "whd" -> `Whd ]
- ];
- sequent_pattern_spec: [
- [ hyp_paths =
- LIST0
- [ id = IDENT ;
- path = OPT [SYMBOL ":" ; path = tactic_term -> path ] ->
- (id,match path with Some p -> p | None -> Ast.UserInput) ];
- goal_path = OPT [ SYMBOL <:unicode<vdash>>; term = tactic_term -> term ] ->
- let goal_path =
- match goal_path, hyp_paths with
- None, [] -> Ast.UserInput
- | None, _::_ -> Ast.Implicit
- | Some goal_path, _ -> goal_path
- in
- hyp_paths,goal_path
- ]
- ];
- pattern_spec: [
- [ res = OPT [
- "in";
- wanted_and_sps =
- [ "match" ; wanted = tactic_term ;
- sps = OPT [ "in"; sps = sequent_pattern_spec -> sps ] ->
- Some wanted,sps
- | sps = sequent_pattern_spec ->
- None,Some sps
- ] ->
- let wanted,hyp_paths,goal_path =
- match wanted_and_sps with
- wanted,None -> wanted, [], Ast.UserInput
- | wanted,Some (hyp_paths,goal_path) -> wanted,hyp_paths,goal_path
- in
- wanted, hyp_paths, goal_path ] ->
- match res with
- None -> None,[],Ast.UserInput
- | Some ps -> ps]
- ];
- direction: [
- [ SYMBOL ">" -> `LeftToRight
- | SYMBOL "<" -> `RightToLeft ]
- ];
- int: [ [ num = NUMBER -> int_of_string num ] ];
- intros_spec: [
- [ num = OPT [ num = int -> num ]; idents = OPT ident_list0 ->
- let idents = match idents with None -> [] | Some idents -> idents in
- num, idents
- ]
- ];
- using: [ [ using = OPT [ IDENT "using"; t = tactic_term -> t ] -> using ] ];
- tactic: [
- [ IDENT "absurd"; t = tactic_term ->
- GrafiteAst.Absurd (loc, t)
- | IDENT "apply"; t = tactic_term ->
- GrafiteAst.Apply (loc, t)
- | IDENT "assumption" ->
- GrafiteAst.Assumption loc
- | IDENT "auto";
- depth = OPT [ IDENT "depth"; SYMBOL "="; i = int -> i ];
- width = OPT [ IDENT "width"; SYMBOL "="; i = int -> i ];
- paramodulation = OPT [ IDENT "paramodulation" ];
- full = OPT [ IDENT "full" ] -> (* ALB *)
- GrafiteAst.Auto (loc,depth,width,paramodulation,full)
- | IDENT "clear"; id = IDENT ->
- GrafiteAst.Clear (loc,id)
- | IDENT "clearbody"; id = IDENT ->
- GrafiteAst.ClearBody (loc,id)
- | IDENT "change"; what = pattern_spec; "with"; t = tactic_term ->
- GrafiteAst.Change (loc, what, t)
- | IDENT "compare"; t = tactic_term ->
- GrafiteAst.Compare (loc,t)
- | IDENT "constructor"; n = int ->
- GrafiteAst.Constructor (loc, n)
- | IDENT "contradiction" ->
- GrafiteAst.Contradiction loc
- | IDENT "cut"; t = tactic_term; ident = OPT [ "as"; id = IDENT -> id] ->
- GrafiteAst.Cut (loc, ident, t)
- | IDENT "decide"; IDENT "equality" ->
- GrafiteAst.DecideEquality loc
- | IDENT "decompose"; types = OPT ident_list0; what = IDENT;
- (num, idents) = intros_spec ->
- let types = match types with None -> [] | Some types -> types in
- let to_spec id = GrafiteAst.Ident id in
- GrafiteAst.Decompose (loc, List.rev_map to_spec types, what, idents)
- | IDENT "discriminate"; t = tactic_term ->
- GrafiteAst.Discriminate (loc, t)
- | IDENT "elim"; what = tactic_term; using = using;
- (num, idents) = intros_spec ->
- GrafiteAst.Elim (loc, what, using, num, idents)
- | IDENT "elimType"; what = tactic_term; using = using;
- (num, idents) = intros_spec ->
- GrafiteAst.ElimType (loc, what, using, num, idents)
- | IDENT "exact"; t = tactic_term ->
- GrafiteAst.Exact (loc, t)
- | IDENT "exists" ->
- GrafiteAst.Exists loc
- | IDENT "fail" -> GrafiteAst.Fail loc
- | IDENT "fold"; kind = reduction_kind; t = tactic_term; p = pattern_spec ->
- let (pt,_,_) = p in
- if pt <> None then
- raise (HExtlib.Localized (loc, CicNotationParser.Parse_error
- ("the pattern cannot specify the term to replace, only its"
- ^ " paths in the hypotheses and in the conclusion")))
- else
- GrafiteAst.Fold (loc, kind, t, p)
- | IDENT "fourier" ->
- GrafiteAst.Fourier loc
- | IDENT "fwd"; hyp = IDENT; idents = OPT ident_list0 ->
- let idents = match idents with None -> [] | Some idents -> idents in
- GrafiteAst.FwdSimpl (loc, hyp, idents)
- | IDENT "generalize"; p=pattern_spec; id = OPT ["as" ; id = IDENT -> id] ->
- GrafiteAst.Generalize (loc,p,id)
- | IDENT "goal"; n = int ->
- GrafiteAst.Goal (loc, n)
- | IDENT "id" -> GrafiteAst.IdTac loc
- | IDENT "injection"; t = tactic_term ->
- GrafiteAst.Injection (loc, t)
- | IDENT "intro"; ident = OPT IDENT ->
- let idents = match ident with None -> [] | Some id -> [id] in
- GrafiteAst.Intros (loc, Some 1, idents)
- | IDENT "intros"; (num, idents) = intros_spec ->
- GrafiteAst.Intros (loc, num, idents)
- | IDENT "lapply";
- depth = OPT [ IDENT "depth"; SYMBOL "="; i = int -> i ];
- what = tactic_term;
- to_what = OPT [ "to" ; t = tactic_term_list1 -> t ];
- ident = OPT [ IDENT "using" ; ident = IDENT -> ident ] ->
- let to_what = match to_what with None -> [] | Some to_what -> to_what in
- GrafiteAst.LApply (loc, depth, to_what, what, ident)
- | IDENT "left" -> GrafiteAst.Left loc
- | IDENT "letin"; where = IDENT ; SYMBOL <:unicode<def>> ; t = tactic_term ->
- GrafiteAst.LetIn (loc, t, where)
- | kind = reduction_kind; p = pattern_spec ->
- GrafiteAst.Reduce (loc, kind, p)
- | IDENT "reflexivity" ->
- GrafiteAst.Reflexivity loc
- | IDENT "replace"; p = pattern_spec; "with"; t = tactic_term ->
- GrafiteAst.Replace (loc, p, t)
- | IDENT "rewrite" ; d = direction; t = tactic_term ; p = pattern_spec ->
- let (pt,_,_) = p in
- if pt <> None then
- raise
- (HExtlib.Localized (loc,
- (CicNotationParser.Parse_error
- "the pattern cannot specify the term to rewrite, only its paths in the hypotheses and in the conclusion")))
- else
- GrafiteAst.Rewrite (loc, d, t, p)
- | IDENT "right" ->
- GrafiteAst.Right loc
- | IDENT "ring" ->
- GrafiteAst.Ring loc
- | IDENT "split" ->
- GrafiteAst.Split loc
- | IDENT "symmetry" ->
- GrafiteAst.Symmetry loc
- | IDENT "transitivity"; t = tactic_term ->
- GrafiteAst.Transitivity (loc, t)
- ]
- ];
- atomic_tactical:
- [ "sequence" LEFTA
- [ t1 = SELF; SYMBOL ";"; t2 = SELF ->
- let ts =
- match t1 with
- | GrafiteAst.Seq (_, l) -> l @ [ t2 ]
- | _ -> [ t1; t2 ]
- in
- GrafiteAst.Seq (loc, ts)
- ]
- | "then" NONA
- [ tac = SELF; SYMBOL ";";
- SYMBOL "["; tacs = LIST0 SELF SEP SYMBOL "|"; SYMBOL "]"->
- (GrafiteAst.Then (loc, tac, tacs))
- ]
- | "loops" RIGHTA
- [ IDENT "do"; count = int; tac = SELF; IDENT "end" ->
- GrafiteAst.Do (loc, count, tac)
- | IDENT "repeat"; tac = SELF; IDENT "end" -> GrafiteAst.Repeat (loc, tac)
- ]
- | "simple" NONA
- [ IDENT "first";
- SYMBOL "["; tacs = LIST0 SELF SEP SYMBOL "|"; SYMBOL "]"->
- GrafiteAst.First (loc, tacs)
- | IDENT "try"; tac = SELF -> GrafiteAst.Try (loc, tac)
- | IDENT "solve";
- SYMBOL "["; tacs = LIST0 SELF SEP SYMBOL "|"; SYMBOL "]"->
- GrafiteAst.Solve (loc, tacs)
- | LPAREN; tac = SELF; RPAREN -> tac
- | tac = tactic -> GrafiteAst.Tactic (loc, tac)
- ]
- ];
- punctuation_tactical:
- [
- [ SYMBOL "[" -> GrafiteAst.Branch loc
- | SYMBOL "|" -> GrafiteAst.Shift loc
- | i = int; SYMBOL ":" -> GrafiteAst.Pos (loc, i)
- | SYMBOL "]" -> GrafiteAst.Merge loc
- | SYMBOL ";" -> GrafiteAst.Semicolon loc
- | SYMBOL "." -> GrafiteAst.Dot loc
- ]
- ];
- tactical:
- [ "simple" NONA
- [ IDENT "focus"; goals = LIST1 int -> GrafiteAst.Focus (loc, goals)
- | IDENT "unfocus" -> GrafiteAst.Unfocus loc
- | IDENT "skip" -> GrafiteAst.Skip loc
- | tac = atomic_tactical LEVEL "loops" -> tac
- ]
- ];
- theorem_flavour: [
- [ [ IDENT "definition" ] -> `Definition
- | [ IDENT "fact" ] -> `Fact
- | [ IDENT "lemma" ] -> `Lemma
- | [ IDENT "remark" ] -> `Remark
- | [ IDENT "theorem" ] -> `Theorem
- ]
- ];
- inductive_spec: [ [
- fst_name = IDENT; params = LIST0 [ arg=arg -> arg ];
- SYMBOL ":"; fst_typ = term; SYMBOL <:unicode<def>>; OPT SYMBOL "|";
- fst_constructors = LIST0 constructor SEP SYMBOL "|";
- tl = OPT [ "with";
- types = LIST1 [
- name = IDENT; SYMBOL ":"; typ = term; SYMBOL <:unicode<def>>;
- OPT SYMBOL "|"; constructors = LIST0 constructor SEP SYMBOL "|" ->
- (name, true, typ, constructors) ] SEP "with" -> types
- ] ->
- let params =
- List.fold_right
- (fun (names, typ) acc ->
- (List.map (fun name -> (name, typ)) names) @ acc)
- params []
- in
- let fst_ind_type = (fst_name, true, fst_typ, fst_constructors) in
- let tl_ind_types = match tl with None -> [] | Some types -> types in
- let ind_types = fst_ind_type :: tl_ind_types in
- (params, ind_types)
- ] ];
-
- record_spec: [ [
- name = IDENT; params = LIST0 [ arg = arg -> arg ] ;
- SYMBOL ":"; typ = term; SYMBOL <:unicode<def>>; SYMBOL "{" ;
- fields = LIST0 [
- name = IDENT ; SYMBOL ":" ; ty = term -> (name,ty)
- ] SEP SYMBOL ";"; SYMBOL "}" ->
- let params =
- List.fold_right
- (fun (names, typ) acc ->
- (List.map (fun name -> (name, typ)) names) @ acc)
- params []
- in
- (params,name,typ,fields)
- ] ];
-
- macro: [
- [ [ IDENT "quit" ] -> GrafiteAst.Quit loc
-(* | [ IDENT "abort" ] -> GrafiteAst.Abort loc *)
-(* | [ IDENT "undo" ]; steps = OPT NUMBER ->
- GrafiteAst.Undo (loc, int_opt steps)
- | [ IDENT "redo" ]; steps = OPT NUMBER ->
- GrafiteAst.Redo (loc, int_opt steps) *)
- | [ IDENT "check" ]; t = term ->
- GrafiteAst.Check (loc, t)
- | [ IDENT "hint" ] -> GrafiteAst.Hint loc
- | [ IDENT "whelp"; "match" ] ; t = term ->
- GrafiteAst.WMatch (loc,t)
- | [ IDENT "whelp"; IDENT "instance" ] ; t = term ->
- GrafiteAst.WInstance (loc,t)
- | [ IDENT "whelp"; IDENT "locate" ] ; id = IDENT ->
- GrafiteAst.WLocate (loc,id)
- | [ IDENT "whelp"; IDENT "elim" ] ; t = term ->
- GrafiteAst.WElim (loc, t)
- | [ IDENT "whelp"; IDENT "hint" ] ; t = term ->
- GrafiteAst.WHint (loc,t)
- | [ IDENT "print" ]; name = QSTRING -> GrafiteAst.Print (loc, name)
- ]
- ];
- alias_spec: [
- [ IDENT "id"; id = QSTRING; SYMBOL "="; uri = QSTRING ->
- let alpha = "[a-zA-Z]" in
- let num = "[0-9]+" in
- let ident_cont = "\\("^alpha^"\\|"^num^"\\|_\\|\\\\\\)" in
- let ident = "\\("^alpha^ident_cont^"*\\|_"^ident_cont^"+\\)" in
- let rex = Str.regexp ("^"^ident^"$") in
- if Str.string_match rex id 0 then
- if (try ignore (UriManager.uri_of_string uri); true
- with UriManager.IllFormedUri _ -> false)
- then
- GrafiteAst.Ident_alias (id, uri)
- else
- raise
- (HExtlib.Localized (loc, CicNotationParser.Parse_error (sprintf "Not a valid uri: %s" uri)))
- else
- raise (HExtlib.Localized (loc, CicNotationParser.Parse_error (
- sprintf "Not a valid identifier: %s" id)))
- | IDENT "symbol"; symbol = QSTRING;
- instance = OPT [ LPAREN; IDENT "instance"; n = int; RPAREN -> n ];
- SYMBOL "="; dsc = QSTRING ->
- let instance =
- match instance with Some i -> i | None -> 0
- in
- GrafiteAst.Symbol_alias (symbol, instance, dsc)
- | IDENT "num";
- instance = OPT [ LPAREN; IDENT "instance"; n = int; RPAREN -> n ];
- SYMBOL "="; dsc = QSTRING ->
- let instance =
- match instance with Some i -> i | None -> 0
- in
- GrafiteAst.Number_alias (instance, dsc)
- ]
- ];
- argument: [
- [ l = LIST0 [ SYMBOL <:unicode<eta>> (* η *); SYMBOL "." -> () ];
- id = IDENT ->
- Ast.IdentArg (List.length l, id)
- ]
- ];
- associativity: [
- [ IDENT "left"; IDENT "associative" -> Gramext.LeftA
- | IDENT "right"; IDENT "associative" -> Gramext.RightA
- | IDENT "non"; IDENT "associative" -> Gramext.NonA
- ]
- ];
- precedence: [
- [ "with"; IDENT "precedence"; n = NUMBER -> int_of_string n ]
- ];
- notation: [
- [ dir = OPT direction; s = QSTRING;
- assoc = OPT associativity; prec = OPT precedence;
- IDENT "for";
- p2 =
- [ blob = UNPARSED_AST ->
- add_raw_attribute ~text:(sprintf "@{%s}" blob)
- (CicNotationParser.parse_level2_ast
- (Ulexing.from_utf8_string blob))
- | blob = UNPARSED_META ->
- add_raw_attribute ~text:(sprintf "${%s}" blob)
- (CicNotationParser.parse_level2_meta
- (Ulexing.from_utf8_string blob))
- ] ->
- let assoc =
- match assoc with
- | None -> default_associativity
- | Some assoc -> assoc
- in
- let prec =
- match prec with
- | None -> default_precedence
- | Some prec -> prec
- in
- let p1 =
- add_raw_attribute ~text:s
- (CicNotationParser.parse_level1_pattern
- (Ulexing.from_utf8_string s))
- in
- (dir, p1, assoc, prec, p2)
- ]
- ];
- level3_term: [
- [ u = URI -> Ast.UriPattern (UriManager.uri_of_string u)
- | id = IDENT -> Ast.VarPattern id
- | SYMBOL "_" -> Ast.ImplicitPattern
- | LPAREN; terms = LIST1 SELF; RPAREN ->
- (match terms with
- | [] -> assert false
- | [term] -> term
- | terms -> Ast.ApplPattern terms)
- ]
- ];
- interpretation: [
- [ s = CSYMBOL; args = LIST0 argument; SYMBOL "="; t = level3_term ->
- (s, args, t)
- ]
- ];
- command: [ [
- IDENT "set"; n = QSTRING; v = QSTRING ->
- GrafiteAst.Set (loc, n, v)
- | IDENT "drop" -> GrafiteAst.Drop loc
- | IDENT "qed" -> GrafiteAst.Qed loc
- | IDENT "variant" ; name = IDENT; SYMBOL ":";
- typ = term; SYMBOL <:unicode<def>> ; newname = IDENT ->
- GrafiteAst.Obj (loc,
- GrafiteAst.Theorem
- (`Variant,name,typ,Some (Ast.Ident (newname, None))))
- | flavour = theorem_flavour; name = IDENT; SYMBOL ":"; typ = term;
- body = OPT [ SYMBOL <:unicode<def>> (* ≝ *); body = term -> body ] ->
- GrafiteAst.Obj (loc,GrafiteAst.Theorem (flavour, name, typ, body))
- | flavour = theorem_flavour; name = IDENT; SYMBOL <:unicode<def>> (* ≝ *);
- body = term ->
- GrafiteAst.Obj (loc,
- GrafiteAst.Theorem (flavour, name, Ast.Implicit, Some body))
- | "let"; ind_kind = [ "corec" -> `CoInductive | "rec"-> `Inductive ];
- defs = CicNotationParser.let_defs ->
- let name,ty =
- match defs with
- | ((Ast.Ident (name, None), Some ty),_,_) :: _ -> name,ty
- | ((Ast.Ident (name, None), None),_,_) :: _ ->
- name, Ast.Implicit
- | _ -> assert false
- in
- let body = Ast.Ident (name,None) in
- GrafiteAst.Obj (loc,GrafiteAst.Theorem(`Definition, name, ty,
- Some (Ast.LetRec (ind_kind, defs, body))))
- | IDENT "inductive"; spec = inductive_spec ->
- let (params, ind_types) = spec in
- GrafiteAst.Obj (loc,GrafiteAst.Inductive (params, ind_types))
- | IDENT "coinductive"; spec = inductive_spec ->
- let (params, ind_types) = spec in
- let ind_types = (* set inductive flags to false (coinductive) *)
- List.map (fun (name, _, term, ctors) -> (name, false, term, ctors))
- ind_types
- in
- GrafiteAst.Obj (loc,GrafiteAst.Inductive (params, ind_types))
- | IDENT "coercion" ; name = IDENT ->
- GrafiteAst.Coercion (loc, Ast.Ident (name,Some []))
- | IDENT "coercion" ; name = URI ->
- GrafiteAst.Coercion (loc, Ast.Uri (name,Some []))
- | IDENT "alias" ; spec = alias_spec ->
- GrafiteAst.Alias (loc, spec)
- | IDENT "record" ; (params,name,ty,fields) = record_spec ->
- GrafiteAst.Obj (loc,GrafiteAst.Record (params,name,ty,fields))
- | IDENT "include" ; path = QSTRING ->
- GrafiteAst.Include (loc,path)
- | IDENT "default" ; what = QSTRING ; uris = LIST1 URI ->
- let uris = List.map UriManager.uri_of_string uris in
- GrafiteAst.Default (loc,what,uris)
- | IDENT "notation"; (dir, l1, assoc, prec, l2) = notation ->
- GrafiteAst.Notation (loc, dir, l1, assoc, prec, l2)
- | IDENT "interpretation"; id = QSTRING;
- (symbol, args, l3) = interpretation ->
- GrafiteAst.Interpretation (loc, id, (symbol, args), l3)
- | IDENT "metadata"; [ IDENT "dependency" | IDENT "baseuri" ] ; URI ->
- (** metadata commands lives only in .moo, where they are in marshalled
- * form *)
- raise (HExtlib.Localized (loc,CicNotationParser.Parse_error "metadata not allowed here"))
-
- | IDENT "dump" -> GrafiteAst.Dump loc
- | IDENT "render"; u = URI ->
- GrafiteAst.Render (loc, UriManager.uri_of_string u)
- ]];
- executable: [
- [ cmd = command; SYMBOL "." -> GrafiteAst.Command (loc, cmd)
- | tac = tactical; punct = punctuation_tactical ->
- GrafiteAst.Tactical (loc, tac, Some punct)
- | punct = punctuation_tactical -> GrafiteAst.Tactical (loc, punct, None)
- | mac = macro; SYMBOL "." -> GrafiteAst.Macro (loc, mac)
- ]
- ];
- comment: [
- [ BEGINCOMMENT ; ex = executable ; ENDCOMMENT ->
- GrafiteAst.Code (loc, ex)
- | str = NOTE ->
- GrafiteAst.Note (loc, str)
- ]
- ];
- statement: [
- [ ex = executable -> GrafiteAst.Executable (loc,ex)
- | com = comment -> GrafiteAst.Comment (loc, com)
- | EOI -> raise End_of_file
- ]
- ];
-END
-
-let exc_located_wrapper f =
- try
- f ()
- with
- | Stdpp.Exc_located (_, End_of_file) -> raise End_of_file
- | Stdpp.Exc_located (floc, Stream.Error msg) ->
- raise (HExtlib.Localized (floc,CicNotationParser.Parse_error msg))
- | Stdpp.Exc_located (floc, exn) ->
- raise
- (HExtlib.Localized (floc,CicNotationParser.Parse_error (Printexc.to_string exn)))
-
-let parse_statement lexbuf =
- exc_located_wrapper
- (fun () -> (Grammar.Entry.parse statement (Obj.magic lexbuf)))
-
-let parse_dependencies lexbuf =
- let tok_stream,_ =
- CicNotationLexer.level2_ast_lexer.Token.tok_func (Obj.magic lexbuf)
- in
- let rec parse acc =
- (parser
- | [< '("URI", u) >] ->
- parse (GrafiteAst.UriDep (UriManager.uri_of_string u) :: acc)
- | [< '("IDENT", "include"); '("QSTRING", fname) >] ->
- parse (GrafiteAst.IncludeDep fname :: acc)
- | [< '("IDENT", "set"); '("QSTRING", "baseuri"); '("QSTRING", baseuri) >] ->
- parse (GrafiteAst.BaseuriDep baseuri :: acc)
- | [< '("EOI", _) >] -> acc
- | [< 'tok >] -> parse acc
- | [< >] -> acc) tok_stream
- in
- List.rev (parse [])
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-type statement =
- (CicNotationPt.term, CicNotationPt.term, GrafiteAst.reduction,
- GrafiteAst.obj, string)
- GrafiteAst.statement
-
-val parse_statement: Ulexing.lexbuf -> statement (** @raise End_of_file *)
-
- (** @raise End_of_file *)
-val parse_dependencies: Ulexing.lexbuf -> GrafiteAst.dependency list
-
-val statement: statement Grammar.Entry.e
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(**************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 16/62003 *)
-(* *)
-(**************************************************************************)
-
-type 'a mpres =
- Mi of attr * string
- | Mn of attr * string
- | Mo of attr * string
- | Mtext of attr * string
- | Mspace of attr
- | Ms of attr * string
- | Mgliph of attr * string
- | Mrow of attr * 'a mpres list
- | Mfrac of attr * 'a mpres * 'a mpres
- | Msqrt of attr * 'a mpres
- | Mroot of attr * 'a mpres * 'a mpres
- | Mstyle of attr * 'a mpres
- | Merror of attr * 'a mpres
- | Mpadded of attr * 'a mpres
- | Mphantom of attr * 'a mpres
- | Mfenced of attr * 'a mpres list
- | Menclose of attr * 'a mpres
- | Msub of attr * 'a mpres * 'a mpres
- | Msup of attr * 'a mpres * 'a mpres
- | Msubsup of attr * 'a mpres * 'a mpres *'a mpres
- | Munder of attr * 'a mpres * 'a mpres
- | Mover of attr * 'a mpres * 'a mpres
- | Munderover of attr * 'a mpres * 'a mpres *'a mpres
-(* | Multiscripts of ??? NOT IMPLEMEMENTED *)
- | Mtable of attr * 'a row list
- | Maction of attr * 'a mpres list
- | Mobject of attr * 'a
-and 'a row = Mtr of attr * 'a mtd list
-and 'a mtd = Mtd of attr * 'a mpres
-and attr = (string option * string * string) list
-;;
-
-let smallskip = Mspace([None,"width","0.5em"]);;
-let indentation = Mspace([None,"width","1em"]);;
-
-let indented elem =
- Mrow([],[indentation;elem]);;
-
-let standard_tbl_attr =
- [None,"align","baseline 1";None,"equalrows","false";None,"columnalign","left"]
-;;
-
-let two_rows_table attr a b =
- Mtable(attr@standard_tbl_attr,
- [Mtr([],[Mtd([],a)]);
- Mtr([],[Mtd([],b)])]);;
-
-let two_rows_table_with_brackets attr a b op =
- (* only the open bracket is added; the closed bracket must be in b *)
- Mtable(attr@standard_tbl_attr,
- [Mtr([],[Mtd([],Mrow([],[Mtext([],"(");a]))]);
- Mtr([],[Mtd([],Mrow([],[indentation;op;b]))])]);;
-
-let two_rows_table_without_brackets attr a b op =
- Mtable(attr@standard_tbl_attr,
- [Mtr([],[Mtd([],a)]);
- Mtr([],[Mtd([],Mrow([],[indentation;op;b]))])]);;
-
-let row_with_brackets attr a b op =
- (* by analogy with two_rows_table_with_brackets we only add the
- open brackets *)
- Mrow(attr,[Mtext([],"(");a;op;b;Mtext([],")")])
-
-let row_without_brackets attr a b op =
- Mrow(attr,[a;op;b])
-
-(* MathML prefix *)
-let prefix = "m";;
-
-let print_mpres obj_printer mpres =
- let module X = Xml in
- let rec aux =
- function
- Mi (attr,s) -> X.xml_nempty ~prefix "mi" attr (X.xml_cdata s)
- | Mn (attr,s) -> X.xml_nempty ~prefix "mn" attr (X.xml_cdata s)
- | Mo (attr,s) ->
- let s =
- let len = String.length s in
- if len > 1 && s.[0] = '\\'
- then String.sub s 1 (len - 1)
- else s
- in
- X.xml_nempty ~prefix "mo" attr (X.xml_cdata s)
- | Mtext (attr,s) -> X.xml_nempty ~prefix "mtext" attr (X.xml_cdata s)
- | Mspace attr -> X.xml_empty ~prefix "mspace" attr
- | Ms (attr,s) -> X.xml_nempty ~prefix "ms" attr (X.xml_cdata s)
- | Mgliph (attr,s) -> X.xml_nempty ~prefix "mgliph" attr (X.xml_cdata s)
- (* General Layout Schemata *)
- | Mrow (attr,l) ->
- X.xml_nempty ~prefix "mrow" attr
- [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>])
- >]
- | Mfrac (attr,m1,m2) ->
- X.xml_nempty ~prefix "mfrac" attr [< aux m1; aux m2 >]
- | Msqrt (attr,m) ->
- X.xml_nempty ~prefix "msqrt" attr [< aux m >]
- | Mroot (attr,m1,m2) ->
- X.xml_nempty ~prefix "mroot" attr [< aux m1; aux m2 >]
- | Mstyle (attr,m) -> X.xml_nempty ~prefix "mstyle" attr [< aux m >]
- | Merror (attr,m) -> X.xml_nempty ~prefix "merror" attr [< aux m >]
- | Mpadded (attr,m) -> X.xml_nempty ~prefix "mpadded" attr [< aux m >]
- | Mphantom (attr,m) -> X.xml_nempty ~prefix "mphantom" attr [< aux m >]
- | Mfenced (attr,l) ->
- X.xml_nempty ~prefix "mfenced" attr
- [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>])
- >]
- | Menclose (attr,m) -> X.xml_nempty ~prefix "menclose" attr [< aux m >]
- (* Script and Limit Schemata *)
- | Msub (attr,m1,m2) ->
- X.xml_nempty ~prefix "msub" attr [< aux m1; aux m2 >]
- | Msup (attr,m1,m2) ->
- X.xml_nempty ~prefix "msup" attr [< aux m1; aux m2 >]
- | Msubsup (attr,m1,m2,m3) ->
- X.xml_nempty ~prefix "msubsup" attr [< aux m1; aux m2; aux m3 >]
- | Munder (attr,m1,m2) ->
- X.xml_nempty ~prefix "munder" attr [< aux m1; aux m2 >]
- | Mover (attr,m1,m2) ->
- X.xml_nempty ~prefix "mover" attr [< aux m1; aux m2 >]
- | Munderover (attr,m1,m2,m3) ->
- X.xml_nempty ~prefix "munderover" attr [< aux m1; aux m2; aux m3 >]
- (* | Multiscripts of ??? NOT IMPLEMEMENTED *)
- (* Tables and Matrices *)
- | Mtable (attr, rl) ->
- X.xml_nempty ~prefix "mtable" attr
- [< (List.fold_right (fun x i -> [< (aux_mrow x) ; i >]) rl [<>]) >]
- (* Enlivening Expressions *)
- | Maction (attr, l) ->
- X.xml_nempty ~prefix "maction" attr
- [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) >]
- | Mobject (attr, obj) ->
- let box_stream = obj_printer obj in
- X.xml_nempty ~prefix "semantics" attr
- [< X.xml_nempty ~prefix "annotation-xml" [None, "encoding", "BoxML"]
- box_stream >]
-
- and aux_mrow =
- let module X = Xml in
- function
- Mtr (attr, l) ->
- X.xml_nempty ~prefix "mtr" attr
- [< (List.fold_right (fun x i -> [< (aux_mtd x) ; i >]) l [<>])
- >]
- and aux_mtd =
- let module X = Xml in
- function
- Mtd (attr,m) -> X.xml_nempty ~prefix "mtd" attr
- [< (aux m) ;
- X.xml_nempty ~prefix "mphantom" []
- (X.xml_nempty ~prefix "mtext" [] (X.xml_cdata "(")) >]
- in
- aux mpres
-;;
-
-let document_of_mpres pres =
- [< Xml.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- Xml.xml_cdata "\n";
- Xml.xml_nempty ~prefix "math"
- [Some "xmlns","m","http://www.w3.org/1998/Math/MathML" ;
- Some "xmlns","helm","http://www.cs.unibo.it/helm" ;
- Some "xmlns","xlink","http://www.w3.org/1999/xlink"
- ] (Xml.xml_nempty ~prefix "mstyle" [None, "mathvariant", "normal"; None,
- "rowspacing", "0.6ex"] (print_mpres (fun _ -> assert false) pres))
- >]
-
-let get_attr = function
- | Maction (attr, _)
- | Menclose (attr, _)
- | Merror (attr, _)
- | Mfenced (attr, _)
- | Mfrac (attr, _, _)
- | Mgliph (attr, _)
- | Mi (attr, _)
- | Mn (attr, _)
- | Mo (attr, _)
- | Mobject (attr, _)
- | Mover (attr, _, _)
- | Mpadded (attr, _)
- | Mphantom (attr, _)
- | Mroot (attr, _, _)
- | Mrow (attr, _)
- | Ms (attr, _)
- | Mspace attr
- | Msqrt (attr, _)
- | Mstyle (attr, _)
- | Msub (attr, _, _)
- | Msubsup (attr, _, _, _)
- | Msup (attr, _, _)
- | Mtable (attr, _)
- | Mtext (attr, _)
- | Munder (attr, _, _)
- | Munderover (attr, _, _, _) ->
- attr
-
-let set_attr attr = function
- | Maction (_, x) -> Maction (attr, x)
- | Menclose (_, x) -> Menclose (attr, x)
- | Merror (_, x) -> Merror (attr, x)
- | Mfenced (_, x) -> Mfenced (attr, x)
- | Mfrac (_, x, y) -> Mfrac (attr, x, y)
- | Mgliph (_, x) -> Mgliph (attr, x)
- | Mi (_, x) -> Mi (attr, x)
- | Mn (_, x) -> Mn (attr, x)
- | Mo (_, x) -> Mo (attr, x)
- | Mobject (_, x) -> Mobject (attr, x)
- | Mover (_, x, y) -> Mover (attr, x, y)
- | Mpadded (_, x) -> Mpadded (attr, x)
- | Mphantom (_, x) -> Mphantom (attr, x)
- | Mroot (_, x, y) -> Mroot (attr, x, y)
- | Mrow (_, x) -> Mrow (attr, x)
- | Ms (_, x) -> Ms (attr, x)
- | Mspace _ -> Mspace attr
- | Msqrt (_, x) -> Msqrt (attr, x)
- | Mstyle (_, x) -> Mstyle (attr, x)
- | Msub (_, x, y) -> Msub (attr, x, y)
- | Msubsup (_, x, y, z) -> Msubsup (attr, x, y, z)
- | Msup (_, x, y) -> Msup (attr, x, y)
- | Mtable (_, x) -> Mtable (attr, x)
- | Mtext (_, x) -> Mtext (attr, x)
- | Munder (_, x, y) -> Munder (attr, x, y)
- | Munderover (_, x, y, z) -> Munderover (attr, x, y, z)
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type 'a mpres =
- (* token elements *)
- Mi of attr * string
- | Mn of attr * string
- | Mo of attr * string
- | Mtext of attr * string
- | Mspace of attr
- | Ms of attr * string
- | Mgliph of attr * string
- (* General Layout Schemata *)
- | Mrow of attr * 'a mpres list
- | Mfrac of attr * 'a mpres * 'a mpres
- | Msqrt of attr * 'a mpres
- | Mroot of attr * 'a mpres * 'a mpres
- | Mstyle of attr * 'a mpres
- | Merror of attr * 'a mpres
- | Mpadded of attr * 'a mpres
- | Mphantom of attr * 'a mpres
- | Mfenced of attr * 'a mpres list
- | Menclose of attr * 'a mpres
- (* Script and Limit Schemata *)
- | Msub of attr * 'a mpres * 'a mpres
- | Msup of attr * 'a mpres * 'a mpres
- | Msubsup of attr * 'a mpres * 'a mpres *'a mpres
- | Munder of attr * 'a mpres * 'a mpres
- | Mover of attr * 'a mpres * 'a mpres
- | Munderover of attr * 'a mpres * 'a mpres *'a mpres
- (* Tables and Matrices *)
- | Mtable of attr * 'a row list
- (* Enlivening Expressions *)
- | Maction of attr * 'a mpres list
- (* Embedding *)
- | Mobject of attr * 'a
-
-and 'a row = Mtr of attr * 'a mtd list
-
-and 'a mtd = Mtd of attr * 'a mpres
-
- (** XML attribute: namespace, name, value *)
-and attr = (string option * string * string) list
-
-;;
-
-val get_attr: 'a mpres -> attr
-val set_attr: attr -> 'a mpres -> 'a mpres
-
-val smallskip : 'a mpres
-val indented : 'a mpres -> 'a mpres
-val standard_tbl_attr : attr
-val two_rows_table : attr -> 'a mpres -> 'a mpres -> 'a mpres
-val two_rows_table_with_brackets :
- attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres
-val two_rows_table_without_brackets :
- attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres
-val row_with_brackets :
- attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres
-val row_without_brackets :
- attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres
-val print_mpres : ('a -> Xml.token Stream.t) -> 'a mpres -> Xml.token Stream.t
-val document_of_mpres : 'a mpres -> Xml.token Stream.t
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Gramext
-
-let tex_of_unicode s =
- let contractions = ("\\Longrightarrow","=>") :: [] in
- if String.length s <= 1 then s
- else (* probably an extended unicode symbol *)
- let s = Utf8Macro.tex_of_unicode s in
- try List.assoc s contractions with Not_found -> s
-
-let needs_brackets t =
- let rec count_brothers = function
- | Node {brother = brother} -> 1 + count_brothers brother
- | _ -> 0
- in
- count_brothers t > 1
-
-let visit_description desc fmt self =
- let skip s = List.mem s [ ] in
- let inline s = List.mem s [ "int" ] in
-
- let rec visit_entry e todo is_son nesting =
- let { ename = ename; edesc = desc } = e in
- if inline ename then
- visit_desc desc todo is_son nesting
- else
- begin
- Format.fprintf fmt "%s " ename;
- if skip ename then
- todo
- else
- todo @ [e]
- end
-
- and visit_desc d todo is_son nesting =
- match d with
- | Dlevels [] -> todo
- | Dlevels [lev] -> visit_level lev todo is_son nesting
- | Dlevels (lev::levels) ->
- let todo = visit_level lev todo is_son nesting in
- List.fold_left
- (fun acc l ->
- Format.fprintf fmt "@ | ";
- visit_level l acc is_son nesting)
- todo levels;
- | _ -> todo
-
- and visit_level l todo is_son nesting =
- let { lsuffix = suff ; lprefix = pref } = l in
- let todo = visit_tree suff todo is_son nesting in
- visit_tree pref todo is_son nesting
-
- and visit_tree t todo is_son nesting =
- match t with
- | Node node -> visit_node node todo is_son nesting
- | _ -> todo
-
- and visit_node n todo is_son nesting =
- let is_tree_printable t =
- match t with
- | Node _ -> true
- | _ -> false
- in
- let { node = symbol; son = son ; brother = brother } = n in
- let todo = visit_symbol symbol todo is_son nesting in
- let todo =
- if is_tree_printable son then
- begin
- let need_b = needs_brackets son in
- if not is_son then
- Format.fprintf fmt "@[<hov2>";
- if need_b then
- Format.fprintf fmt "( ";
- let todo = visit_tree son todo true nesting in
- if need_b then
- Format.fprintf fmt ")";
- if not is_son then
- Format.fprintf fmt "@]";
- todo
- end
- else
- todo
- in
- if is_tree_printable brother then
- begin
- Format.fprintf fmt "@ | ";
- visit_tree brother todo is_son nesting
- end
- else
- todo
-
- and visit_symbol s todo is_son nesting =
- match s with
- | Smeta (name, sl, _) ->
- Format.fprintf fmt "%s " name;
- List.fold_left (
- fun acc s ->
- let todo = visit_symbol s acc is_son nesting in
- if is_son then
- Format.fprintf fmt "@ ";
- todo)
- todo sl
- | Snterm entry -> visit_entry entry todo is_son nesting
- | Snterml (entry,_) -> visit_entry entry todo is_son nesting
- | Slist0 symbol ->
- Format.fprintf fmt "{@[<hov2> ";
- let todo = visit_symbol symbol todo is_son (nesting+1) in
- Format.fprintf fmt "@]} @ ";
- todo
- | Slist0sep (symbol,sep) ->
- Format.fprintf fmt "[@[<hov2> ";
- let todo = visit_symbol symbol todo is_son (nesting + 1) in
- Format.fprintf fmt "{@[<hov2> ";
- let todo = visit_symbol sep todo is_son (nesting + 2) in
- Format.fprintf fmt " ";
- let todo = visit_symbol symbol todo is_son (nesting + 2) in
- Format.fprintf fmt "@]} @]] @ ";
- todo
- | Slist1 symbol ->
- Format.fprintf fmt "{@[<hov2> ";
- let todo = visit_symbol symbol todo is_son (nesting + 1) in
- Format.fprintf fmt "@]}+ @ ";
- todo
- | Slist1sep (symbol,sep) ->
- let todo = visit_symbol symbol todo is_son nesting in
- Format.fprintf fmt "{@[<hov2> ";
- let todo = visit_symbol sep todo is_son (nesting + 1) in
- let todo = visit_symbol symbol todo is_son (nesting + 1) in
- Format.fprintf fmt "@]} @ ";
- todo
- | Sopt symbol ->
- Format.fprintf fmt "[@[<hov2> ";
- let todo = visit_symbol symbol todo is_son (nesting + 1) in
- Format.fprintf fmt "@]] @ ";
- todo
- | Sself -> Format.fprintf fmt "%s " self; todo
- | Snext -> Format.fprintf fmt "next "; todo
- | Stoken pattern ->
- let constructor, keyword = pattern in
- if keyword = "" then
- Format.fprintf fmt "`%s' " constructor
- else
- Format.fprintf fmt "\"%s\" " (tex_of_unicode keyword);
- todo
- | Stree tree ->
- if needs_brackets tree then
- begin
- Format.fprintf fmt "@[<hov2>( ";
- let todo = visit_tree tree todo is_son (nesting + 1) in
- Format.fprintf fmt ")@] @ ";
- todo
- end
- else
- visit_tree tree todo is_son (nesting + 1)
- in
- visit_desc desc [] false 0
-;;
-
-let rec clean_dummy_desc = function
- | Dlevels l -> Dlevels (clean_levels l)
- | x -> x
-
-and clean_levels = function
- | [] -> []
- | l :: tl -> clean_level l @ clean_levels tl
-
-and clean_level = function
- | x ->
- let pref = clean_tree x.lprefix in
- let suff = clean_tree x.lsuffix in
- match pref,suff with
- | DeadEnd, DeadEnd -> []
- | _ -> [{x with lprefix = pref; lsuffix = suff}]
-
-and clean_tree = function
- | Node n -> clean_node n
- | x -> x
-
-and clean_node = function
- | {node=node;son=son;brother=brother} ->
- let bn = is_symbol_dummy node in
- let bs = is_tree_dummy son in
- let bb = is_tree_dummy brother in
- let son = if bs then DeadEnd else son in
- let brother = if bb then DeadEnd else brother in
- if bb && bs && bn then
- DeadEnd
- else
- if bn then
- Node {node=Sself;son=son;brother=brother}
- else
- Node {node=node;son=son;brother=brother}
-
-and is_level_dummy = function
- | {lsuffix=lsuffix;lprefix=lprefix} ->
- is_tree_dummy lsuffix && is_tree_dummy lprefix
-
-and is_desc_dummy = function
- | Dlevels l -> List.for_all is_level_dummy l
- | Dparser _ -> true
-
-and is_entry_dummy = function
- | {edesc=edesc} -> is_desc_dummy edesc
-
-and is_symbol_dummy = function
- | Stoken ("DUMMY", _) -> true
- | Stoken _ -> false
- | Smeta (_, lt, _) -> List.for_all is_symbol_dummy lt
- | Snterm e | Snterml (e, _) -> is_entry_dummy e
- | Slist1 x | Slist0 x -> is_symbol_dummy x
- | Slist1sep (x,y) | Slist0sep (x,y) -> is_symbol_dummy x && is_symbol_dummy y
- | Sopt x -> is_symbol_dummy x
- | Sself | Snext -> false
- | Stree t -> is_tree_dummy t
-
-and is_tree_dummy = function
- | Node {node=node} -> is_symbol_dummy node
- | _ -> true
-;;
-
-
-let rec visit_entries todo pped =
- let fmt = Format.std_formatter in
- match todo with
- | [] -> ()
- | hd :: tl ->
- let todo =
- if not (List.memq hd pped) then
- begin
- let { ename = ename; edesc = desc } = hd in
- Format.fprintf fmt "@[<hv2>%s ::=@ " ename;
- let desc = clean_dummy_desc desc in
- let todo = visit_description desc fmt ename @ todo in
- Format.fprintf fmt "@]";
- Format.pp_print_newline fmt ();
- Format.pp_print_newline fmt ();
- todo
- end
- else
- todo
- in
- let clean_todo todo =
- let name_of_entry e = e.ename in
- let pped = hd :: pped in
- let todo = tl @ todo in
- let todo = List.filter (fun e -> not(List.memq e pped)) todo in
- HExtlib.list_uniq
- ~eq:(fun e1 e2 -> (name_of_entry e1) = (name_of_entry e2))
- (List.sort
- (fun e1 e2 ->
- Pervasives.compare (name_of_entry e1) (name_of_entry e2))
- todo),
- pped
- in
- let todo,pped = clean_todo todo in
- visit_entries todo pped
-;;
-
-let _ =
- let g_entry = Grammar.Entry.obj GrafiteParser.statement in
- visit_entries [g_entry] []
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-type xml_attribute = string option * string * string
-type markup = [ `MathML | `BoxML ]
-
-let keyword_attributes = function
- | `MathML -> [ None, "mathcolor", "blue" ]
- | `BoxML -> [ None, "color", "blue" ]
-
-let builtin_symbol_attributes = function
- | `MathML -> [ None, "mathcolor", "blue" ]
- | `BoxML -> [ None, "color", "blue" ]
-
-let object_keyword_attributes = function
- | `MathML -> [ None, "mathcolor", "red" ]
- | `BoxML -> [ None, "color", "red" ]
-
-let symbol_attributes _ = []
-let ident_attributes _ = []
-let number_attributes _ = []
-
-let spacing_attributes _ = [ None, "spacing", "0.5em" ]
-let indent_attributes _ = [ None, "indent", "0.5em" ]
-let small_skip_attributes _ = [ None, "width", "0.5em" ]
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(** XML attributes for MathML/BoxML rendering of terms and objects
- * markup defaults to MathML in all functions below *)
-
-type xml_attribute = string option * string * string
-type markup = [ `MathML | `BoxML ]
-
-(** High-level attributes *)
-
-val keyword_attributes: (* let, match, in, ... *)
- markup -> xml_attribute list
-
-val builtin_symbol_attributes: (* \\Pi, \\to, ... *)
- markup -> xml_attribute list
-
-val symbol_attributes: (* +, *, ... *)
- markup -> xml_attribute list
-
-val ident_attributes: (* nat, plus, ... *)
- markup -> xml_attribute list
-
-val number_attributes: (* 1, 2, ... *)
- markup -> xml_attribute list
-
-val object_keyword_attributes: (* Body, Definition, ... *)
- markup -> xml_attribute list
-
-(** Low-level attributes *)
-
-val spacing_attributes: markup -> xml_attribute list
-val indent_attributes: markup -> xml_attribute list
-val small_skip_attributes: markup -> xml_attribute list
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-let _ =
- let ic = ref stdin in
- let usage = "test_coarse_parser [ file ]" in
- let open_file fname =
- if !ic <> stdin then close_in !ic;
- ic := open_in fname
- in
- Arg.parse [] open_file usage;
- let deps =
- GrafiteParser.parse_dependencies (Ulexing.from_utf8_channel !ic)
- in
- List.iter (fun dep -> print_endline (GrafiteAstPp.pp_dependency dep)) deps
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-let _ =
- let level = ref "2@" in
- let ic = ref stdin in
- let arg_spec = [ "-level", Arg.Set_string level, "set the notation level" ] in
- let usage = "test_lexer [ -level level ] [ file ]" in
- let open_file fname =
- if !ic <> stdin then close_in !ic;
- ic := open_in fname
- in
- Arg.parse arg_spec open_file usage;
- let lexer =
- match !level with
- "1" -> CicNotationLexer.level1_pattern_lexer
- | "2@" -> CicNotationLexer.level2_ast_lexer
- | "2$" -> CicNotationLexer.level2_meta_lexer
- | l ->
- prerr_endline (Printf.sprintf "Unsupported level %s" l);
- exit 2
- in
- let token_stream =
- fst (lexer.Token.tok_func (Obj.magic (Ulexing.from_utf8_channel !ic)))
- in
- Printf.printf "Lexing notation level %s\n" !level; flush stdout;
- let rec dump () =
- let (a,b) = Stream.next token_stream in
- if a = "EOI" then raise Stream.Failure;
- print_endline (Printf.sprintf "%s '%s'" a b);
- dump ()
- in
- try
- dump ()
- with Stream.Failure -> ()
-
+++ /dev/null
-<helm_registry>
- <section name="getter">
- <key name="prefix">
- cic:/
- file:///projects/helm/library/coq_contribs/
- </key>
- <key name="prefix">
- cic:/matita/
- file:///home/zacchiro/helm/matita/.matita/xml/matita/
- </key>
- </section>
- <section name="notation">
- <key name="core_file">../../matita/core_notation.moo</key>
- </section>
-</helm_registry>
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Printf
-
-let _ = Helm_registry.load_from "test_parser.conf.xml"
-
-let xml_stream_of_markup =
- let rec print_box (t: CicNotationPres.boxml_markup) =
- Box.box2xml print_mpres t
- and print_mpres (t: CicNotationPres.mathml_markup) =
- Mpresentation.print_mpres print_box t
- in
- print_mpres
-
-let dump_xml t id_to_uri fname =
- prerr_endline (sprintf "dumping MathML to %s ..." fname);
- flush stdout;
- let oc = open_out fname in
- let markup = CicNotationPres.render id_to_uri t in
- let xml_stream = CicNotationPres.print_xml markup in
- Xml.pp_to_outchan xml_stream oc;
- close_out oc
-
-let extract_loc =
- function
- | GrafiteAst.Executable (loc, _)
- | GrafiteAst.Comment (loc, _) -> loc
-
-let pp_associativity = function
- | Gramext.LeftA -> "left"
- | Gramext.RightA -> "right"
- | Gramext.NonA -> "non"
-
-let pp_precedence = string_of_int
-
-(* let last_rule_id = ref None *)
-
-let process_stream istream =
- let char_count = ref 0 in
- let module P = CicNotationPt in
- let module G = GrafiteAst in
- try
- while true do
- try
- let statement = GrafiteParser.parse_statement istream in
- let floc = extract_loc statement in
- let (_, y) = HExtlib.loc_of_floc floc in
- char_count := y + !char_count;
- match statement with
-(* | G.Executable (_, G.Macro (_, G.Check (_,
- P.AttributedTerm (_, P.Ident _)))) ->
- prerr_endline "mega hack";
- (match !last_rule_id with
- | None -> ()
- | Some id ->
- prerr_endline "removing last notation rule ...";
- CicNotationParser.delete id) *)
- | G.Executable (_, G.Macro (_, G.Check (_, t))) ->
- prerr_endline (sprintf "ast: %s" (CicNotationPp.pp_term t));
- let t' = CicNotationRew.pp_ast t in
- prerr_endline (sprintf "rendered ast: %s"
- (CicNotationPp.pp_term t'));
- let tbl = Hashtbl.create 0 in
- dump_xml t' tbl "out.xml"
- | G.Executable (_, G.Command (_,
- G.Notation (_, dir, l1, associativity, precedence, l2))) ->
- prerr_endline "notation";
- prerr_endline (sprintf "l1: %s" (CicNotationPp.pp_term l1));
- prerr_endline (sprintf "l2: %s" (CicNotationPp.pp_term l2));
- prerr_endline (sprintf "prec: %s" (pp_precedence precedence));
- prerr_endline (sprintf "assoc: %s" (pp_associativity associativity));
- let keywords = CicNotationUtil.keywords_of_term l1 in
- if keywords <> [] then
- prerr_endline (sprintf "keywords: %s"
- (String.concat " " keywords));
- if dir <> Some `RightToLeft then
- ignore
- (CicNotationParser.extend l1 ?precedence ?associativity
- (fun env loc -> CicNotationFwd.instantiate_level2 env l2));
-(* last_rule_id := Some rule_id; *)
- if dir <> Some `LeftToRight then
- ignore (CicNotationRew.add_pretty_printer
- ?precedence ?associativity l2 l1)
- | G.Executable (_, G.Command (_, G.Interpretation (_, id, l2, l3))) ->
- prerr_endline "interpretation";
- prerr_endline (sprintf "dsc: %s" id);
- ignore (CicNotationRew.add_interpretation id l2 l3);
- flush stdout
- | G.Executable (_, G.Command (_, G.Dump _)) ->
- CicNotationParser.print_l2_pattern (); print_newline ()
- | G.Executable (_, G.Command (_, G.Render (_, uri))) ->
- let obj, _ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- let annobj, _, _, id_to_sort, _, _, _ =
- Cic2acic.acic_object_of_cic_object obj
- in
- let annterm =
- match annobj with
- | Cic.AConstant (_, _, _, _, ty, _, _)
- | Cic.AVariable (_, _, _, ty, _, _) -> ty
- | _ -> assert false
- in
- let t, id_to_uri =
- CicNotationRew.ast_of_acic id_to_sort annterm
- in
- prerr_endline "Raw AST";
- prerr_endline (CicNotationPp.pp_term t);
- let t' = CicNotationRew.pp_ast t in
- prerr_endline "Rendered AST";
- prerr_endline (CicNotationPp.pp_term t');
- dump_xml t' id_to_uri "out.xml"
- | _ -> prerr_endline "Unsupported statement"
- with
- | End_of_file -> raise End_of_file
- | HExtlib.Localized (floc,CicNotationParser.Parse_error msg) ->
- let (x, y) = HExtlib.loc_of_floc floc in
-(* let before = String.sub line 0 x in
- let error = String.sub line x (y - x) in
- let after = String.sub line y (String.length line - y) in
- eprintf "%s\e[01;31m%s\e[00m%s\n" before error after;
- prerr_endline (sprintf "at character %d-%d: %s" x y msg) *)
- prerr_endline (sprintf "Parse error at character %d-%d: %s"
- (!char_count + x) (!char_count + y) msg)
- | exn ->
- prerr_endline
- (sprintf "Uncaught exception: %s" (Printexc.to_string exn))
- done
- with End_of_file -> ()
-
-let _ =
- let arg_spec = [ ] in
- let usage = "" in
- Arg.parse arg_spec (fun _ -> raise (Arg.Bad usage)) usage;
- print_endline "Loading builtin notation ...";
- CicNotation.load_notation (Helm_registry.get "notation.core_file");
- print_endline "done.";
- flush stdout;
- process_stream (Ulexing.from_utf8_channel stdin)
-
+++ /dev/null
-*.cm[iaox] *.cmxa
+++ /dev/null
-contentPp.cmi: content.cmi
-cic2content.cmi: content.cmi cic2acic.cmi
-content2cic.cmi: content.cmi
-eta_fixing.cmo: eta_fixing.cmi
-eta_fixing.cmx: eta_fixing.cmi
-doubleTypeInference.cmo: doubleTypeInference.cmi
-doubleTypeInference.cmx: doubleTypeInference.cmi
-cic2acic.cmo: eta_fixing.cmi doubleTypeInference.cmi cic2acic.cmi
-cic2acic.cmx: eta_fixing.cmx doubleTypeInference.cmx cic2acic.cmi
-content.cmo: content.cmi
-content.cmx: content.cmi
-contentPp.cmo: content.cmi contentPp.cmi
-contentPp.cmx: content.cmx contentPp.cmi
-cic2content.cmo: content.cmi cic2acic.cmi cic2content.cmi
-cic2content.cmx: content.cmx cic2acic.cmx cic2content.cmi
-content2cic.cmo: content.cmi content2cic.cmi
-content2cic.cmx: content.cmx content2cic.cmi
+++ /dev/null
-PACKAGE = cic_omdoc
-PREDICATES =
-
-INTERFACE_FILES = \
- eta_fixing.mli \
- doubleTypeInference.mli \
- cic2acic.mli \
- content.mli \
- contentPp.mli \
- cic2content.mli \
- content2cic.mli \
- $(NULL)
-IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
-
-EXTRA_OBJECTS_TO_INSTALL = \
-EXTRA_OBJECTS_TO_CLEAN =
-
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type sort_kind = [ `Prop | `Set | `Type of CicUniv.universe | `CProp ]
-
-let string_of_sort = function
- | `Prop -> "Prop"
- | `Set -> "Set"
- | `Type u -> "Type:" ^ string_of_int (CicUniv.univno u)
- | `CProp -> "CProp"
-
-let sort_of_sort = function
- | Cic.Prop -> `Prop
- | Cic.Set -> `Set
- | Cic.Type u -> `Type u
- | Cic.CProp -> `CProp
-
-(* let hashtbl_add_time = ref 0.0;; *)
-
-let xxx_add h k v =
-(* let t1 = Sys.time () in *)
- Hashtbl.add h k v ;
-(* let t2 = Sys.time () in
- hashtbl_add_time := !hashtbl_add_time +. t2 -. t1 *)
-;;
-
-(* let number_new_type_of_aux' = ref 0;;
-let type_of_aux'_add_time = ref 0.0;; *)
-
-let xxx_type_of_aux' m c t =
-(* let t1 = Sys.time () in *)
- let res,_ =
- try
- CicTypeChecker.type_of_aux' m c t CicUniv.empty_ugraph
- with
- | CicTypeChecker.AssertFailure _
- | CicTypeChecker.TypeCheckerFailure _ ->
- Cic.Sort Cic.Prop, CicUniv.empty_ugraph
- in
-(* let t2 = Sys.time () in
- type_of_aux'_add_time := !type_of_aux'_add_time +. t2 -. t1 ; *)
- res
-;;
-
-type anntypes =
- {annsynthesized : Cic.annterm ; annexpected : Cic.annterm option}
-;;
-
-let gen_id seed =
- let res = "i" ^ string_of_int !seed in
- incr seed ;
- res
-;;
-
-let fresh_id seed ids_to_terms ids_to_father_ids =
- fun father t ->
- let res = gen_id seed in
- xxx_add ids_to_father_ids res father ;
- xxx_add ids_to_terms res t ;
- res
-;;
-
-let source_id_of_id id = "#source#" ^ id;;
-
-exception NotEnoughElements;;
-
-(*CSC: cut&paste da cicPp.ml *)
-(* get_nth l n returns the nth element of the list l if it exists or *)
-(* raises NotEnoughElements if l has less than n elements *)
-let rec get_nth l n =
- match (n,l) with
- (1, he::_) -> he
- | (n, he::tail) when n > 1 -> get_nth tail (n-1)
- | (_,_) -> raise NotEnoughElements
-;;
-
-let acic_of_cic_context' ~computeinnertypes:global_computeinnertypes
- seed ids_to_terms ids_to_father_ids ids_to_inner_sorts ids_to_inner_types
- metasenv context idrefs t expectedty
-=
- let module D = DoubleTypeInference in
- let module C = Cic in
- let fresh_id' = fresh_id seed ids_to_terms ids_to_father_ids in
-(* let time1 = Sys.time () in *)
- let terms_to_types =
-(*
- let time0 = Sys.time () in
- let prova = CicTypeChecker.type_of_aux' metasenv context t in
- let time1 = Sys.time () in
- prerr_endline ("*** Fine type_inference:" ^ (string_of_float (time1 -. time0)));
- let res = D.double_type_of metasenv context t expectedty in
- let time2 = Sys.time () in
- prerr_endline ("*** Fine double_type_inference:" ^ (string_of_float (time2 -. time1)));
- res
-*)
- if global_computeinnertypes then
- D.double_type_of metasenv context t expectedty
- else
- D.CicHash.empty ()
- in
-(*
- let time2 = Sys.time () in
- prerr_endline
- ("++++++++++++ Tempi della double_type_of: "^ string_of_float (time2 -. time1)) ;
-*)
- let rec aux computeinnertypes father context idrefs tt =
- let fresh_id'' = fresh_id' father tt in
- (*CSC: computeinnertypes era true, il che e' proprio sbagliato, no? *)
- let aux' = aux computeinnertypes (Some fresh_id'') in
- (* First of all we compute the inner type and the inner sort *)
- (* of the term. They may be useful in what follows. *)
- (*CSC: This is a very inefficient way of computing inner types *)
- (*CSC: and inner sorts: very deep terms have their types/sorts *)
- (*CSC: computed again and again. *)
- let sort_of t =
- match CicReduction.whd context t with
- C.Sort C.Prop -> `Prop
- | C.Sort C.Set -> `Set
- | C.Sort (C.Type u) -> `Type u
- | C.Meta _ -> `Type (CicUniv.fresh())
- | C.Sort C.CProp -> `CProp
- | t ->
- prerr_endline ("Cic2acic.sort_of applied to: " ^ CicPp.ppterm t) ;
- assert false
- in
- let ainnertypes,innertype,innersort,expected_available =
-(*CSC: Here we need the algorithm for Coscoy's double type-inference *)
-(*CSC: (expected type + inferred type). Just for now we use the usual *)
-(*CSC: type-inference, but the result is very poor. As a very weak *)
-(*CSC: patch, I apply whd to the computed type. Full beta *)
-(*CSC: reduction would be a much better option. *)
-(*CSC: solo per testare i tempi *)
-(*XXXXXXX *)
- try
-(* *)
- let {D.synthesized = synthesized; D.expected = expected} =
- if computeinnertypes then
- D.CicHash.find terms_to_types tt
- else
- (* We are already in an inner-type and Coscoy's double *)
- (* type inference algorithm has not been applied. *)
- { D.synthesized =
-(***CSC: patch per provare i tempi
- CicReduction.whd context (xxx_type_of_aux' metasenv context tt) ; *)
- if global_computeinnertypes then
- Cic.Sort (Cic.Type (CicUniv.fresh()))
- else
- CicReduction.whd context (xxx_type_of_aux' metasenv context tt);
- D.expected = None}
- in
-(* incr number_new_type_of_aux' ; *)
- let innersort = (*XXXXX *) xxx_type_of_aux' metasenv context synthesized (* Cic.Sort Cic.Prop *) in
- let ainnertypes,expected_available =
- if computeinnertypes then
- let annexpected,expected_available =
- match expected with
- None -> None,false
- | Some expectedty' ->
- Some
- (aux false (Some fresh_id'') context idrefs expectedty'),
- true
- in
- Some
- {annsynthesized =
- aux false (Some fresh_id'') context idrefs synthesized ;
- annexpected = annexpected
- }, expected_available
- else
- None,false
- in
- ainnertypes,synthesized, sort_of innersort, expected_available
-(*XXXXXXXX *)
- with
- Not_found -> (* l'inner-type non e' nella tabella ==> sort <> Prop *)
- (* CSC: Type or Set? I can not tell *)
- let u = CicUniv.fresh() in
- None,Cic.Sort (Cic.Type u),`Type u,false
- (* TASSI non dovrebbe fare danni *)
-(* *)
- in
- let add_inner_type id =
- match ainnertypes with
- None -> ()
- | Some ainnertypes -> xxx_add ids_to_inner_types id ainnertypes
- in
- match tt with
- C.Rel n ->
- let id =
- match get_nth context n with
- (Some (C.Name s,_)) -> s
- | _ -> "__" ^ string_of_int n
- in
- xxx_add ids_to_inner_sorts fresh_id'' innersort ;
- if innersort = `Prop && expected_available then
- add_inner_type fresh_id'' ;
- C.ARel (fresh_id'', List.nth idrefs (n-1), n, id)
- | C.Var (uri,exp_named_subst) ->
- xxx_add ids_to_inner_sorts fresh_id'' innersort ;
- if innersort = `Prop && expected_available then
- add_inner_type fresh_id'' ;
- let exp_named_subst' =
- List.map
- (function i,t -> i, (aux' context idrefs t)) exp_named_subst
- in
- C.AVar (fresh_id'', uri,exp_named_subst')
- | C.Meta (n,l) ->
- let (_,canonical_context,_) = CicUtil.lookup_meta n metasenv in
- xxx_add ids_to_inner_sorts fresh_id'' innersort ;
- if innersort = `Prop && expected_available then
- add_inner_type fresh_id'' ;
- C.AMeta (fresh_id'', n,
- (List.map2
- (fun ct t ->
- match (ct, t) with
- | None, _ -> None
- | _, Some t -> Some (aux' context idrefs t)
- | Some _, None -> assert false (* due to typing rules *))
- canonical_context l))
- | C.Sort s -> C.ASort (fresh_id'', s)
- | C.Implicit annotation -> C.AImplicit (fresh_id'', annotation)
- | C.Cast (v,t) ->
- xxx_add ids_to_inner_sorts fresh_id'' innersort ;
- if innersort = `Prop then
- add_inner_type fresh_id'' ;
- C.ACast (fresh_id'', aux' context idrefs v, aux' context idrefs t)
- | C.Prod (n,s,t) ->
- xxx_add ids_to_inner_sorts fresh_id''
- (sort_of innertype) ;
- let sourcetype = xxx_type_of_aux' metasenv context s in
- xxx_add ids_to_inner_sorts (source_id_of_id fresh_id'')
- (sort_of sourcetype) ;
- let n' =
- match n with
- C.Anonymous -> n
- | C.Name n' ->
- if DoubleTypeInference.does_not_occur 1 t then
- C.Anonymous
- else
- C.Name n'
- in
- C.AProd
- (fresh_id'', n', aux' context idrefs s,
- aux' ((Some (n, C.Decl s))::context) (fresh_id''::idrefs) t)
- | C.Lambda (n,s,t) ->
- xxx_add ids_to_inner_sorts fresh_id'' innersort ;
- let sourcetype = xxx_type_of_aux' metasenv context s in
- xxx_add ids_to_inner_sorts (source_id_of_id fresh_id'')
- (sort_of sourcetype) ;
- if innersort = `Prop then
- begin
- let father_is_lambda =
- match father with
- None -> false
- | Some father' ->
- match Hashtbl.find ids_to_terms father' with
- C.Lambda _ -> true
- | _ -> false
- in
- if (not father_is_lambda) || expected_available then
- add_inner_type fresh_id''
- end ;
- C.ALambda
- (fresh_id'',n, aux' context idrefs s,
- aux' ((Some (n, C.Decl s)::context)) (fresh_id''::idrefs) t)
- | C.LetIn (n,s,t) ->
- xxx_add ids_to_inner_sorts fresh_id'' innersort ;
- if innersort = `Prop then
- add_inner_type fresh_id'' ;
- C.ALetIn
- (fresh_id'', n, aux' context idrefs s,
- aux' ((Some (n, C.Def(s,None)))::context) (fresh_id''::idrefs) t)
- | C.Appl l ->
- xxx_add ids_to_inner_sorts fresh_id'' innersort ;
- if innersort = `Prop then
- add_inner_type fresh_id'' ;
- C.AAppl (fresh_id'', List.map (aux' context idrefs) l)
- | C.Const (uri,exp_named_subst) ->
- xxx_add ids_to_inner_sorts fresh_id'' innersort ;
- if innersort = `Prop && expected_available then
- add_inner_type fresh_id'' ;
- let exp_named_subst' =
- List.map
- (function i,t -> i, (aux' context idrefs t)) exp_named_subst
- in
- C.AConst (fresh_id'', uri, exp_named_subst')
- | C.MutInd (uri,tyno,exp_named_subst) ->
- let exp_named_subst' =
- List.map
- (function i,t -> i, (aux' context idrefs t)) exp_named_subst
- in
- C.AMutInd (fresh_id'', uri, tyno, exp_named_subst')
- | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
- xxx_add ids_to_inner_sorts fresh_id'' innersort ;
- if innersort = `Prop && expected_available then
- add_inner_type fresh_id'' ;
- let exp_named_subst' =
- List.map
- (function i,t -> i, (aux' context idrefs t)) exp_named_subst
- in
- C.AMutConstruct (fresh_id'', uri, tyno, consno, exp_named_subst')
- | C.MutCase (uri, tyno, outty, term, patterns) ->
- xxx_add ids_to_inner_sorts fresh_id'' innersort ;
- if innersort = `Prop then
- add_inner_type fresh_id'' ;
- C.AMutCase (fresh_id'', uri, tyno, aux' context idrefs outty,
- aux' context idrefs term, List.map (aux' context idrefs) patterns)
- | C.Fix (funno, funs) ->
- let fresh_idrefs =
- List.map (function _ -> gen_id seed) funs in
- let new_idrefs = List.rev fresh_idrefs @ idrefs in
- let tys =
- List.map (fun (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) funs
- in
- xxx_add ids_to_inner_sorts fresh_id'' innersort ;
- if innersort = `Prop then
- add_inner_type fresh_id'' ;
- C.AFix (fresh_id'', funno,
- List.map2
- (fun id (name, indidx, ty, bo) ->
- (id, name, indidx, aux' context idrefs ty,
- aux' (tys@context) new_idrefs bo)
- ) fresh_idrefs funs
- )
- | C.CoFix (funno, funs) ->
- let fresh_idrefs =
- List.map (function _ -> gen_id seed) funs in
- let new_idrefs = List.rev fresh_idrefs @ idrefs in
- let tys =
- List.map (fun (name,ty,_) -> Some (C.Name name, C.Decl ty)) funs
- in
- xxx_add ids_to_inner_sorts fresh_id'' innersort ;
- if innersort = `Prop then
- add_inner_type fresh_id'' ;
- C.ACoFix (fresh_id'', funno,
- List.map2
- (fun id (name, ty, bo) ->
- (id, name, aux' context idrefs ty,
- aux' (tys@context) new_idrefs bo)
- ) fresh_idrefs funs
- )
- in
-(*
- let timea = Sys.time () in
- let res = aux true None context idrefs t in
- let timeb = Sys.time () in
- prerr_endline
- ("+++++++++++++ Tempi della aux dentro alla acic_of_cic: "^ string_of_float (timeb -. timea)) ;
- res
-*)
- aux global_computeinnertypes None context idrefs t
-;;
-
-let acic_of_cic_context ~computeinnertypes metasenv context idrefs t =
- let ids_to_terms = Hashtbl.create 503 in
- let ids_to_father_ids = Hashtbl.create 503 in
- let ids_to_inner_sorts = Hashtbl.create 503 in
- let ids_to_inner_types = Hashtbl.create 503 in
- let seed = ref 0 in
- acic_of_cic_context' ~computeinnertypes seed ids_to_terms ids_to_father_ids ids_to_inner_sorts
- ids_to_inner_types metasenv context idrefs t,
- ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types
-;;
-
-let aconjecture_of_conjecture seed ids_to_terms ids_to_father_ids
- ids_to_inner_sorts ids_to_inner_types ids_to_hypotheses hypotheses_seed
- metasenv (metano,context,goal)
-=
- let computeinnertypes = false in
- let acic_of_cic_context =
- acic_of_cic_context' seed ids_to_terms ids_to_father_ids ids_to_inner_sorts
- ids_to_inner_types metasenv in
- let _, acontext,final_idrefs =
- (List.fold_right
- (fun binding (context, acontext,idrefs) ->
- let hid = "h" ^ string_of_int !hypotheses_seed in
- Hashtbl.add ids_to_hypotheses hid binding ;
- incr hypotheses_seed ;
- match binding with
- Some (n,Cic.Def (t,_)) ->
- let acic = acic_of_cic_context ~computeinnertypes context idrefs t None in
- (binding::context),
- ((hid,Some (n,Cic.ADef acic))::acontext),(hid::idrefs)
- | Some (n,Cic.Decl t) ->
- let acic = acic_of_cic_context ~computeinnertypes context idrefs t None in
- (binding::context),
- ((hid,Some (n,Cic.ADecl acic))::acontext),(hid::idrefs)
- | None ->
- (* Invariant: "" is never looked up *)
- (None::context),((hid,None)::acontext),""::idrefs
- ) context ([],[],[])
- )
- in
- let agoal = acic_of_cic_context ~computeinnertypes context final_idrefs goal None in
- (metano,acontext,agoal)
-;;
-
-let asequent_of_sequent (metasenv:Cic.metasenv) (sequent:Cic.conjecture) =
- let ids_to_terms = Hashtbl.create 503 in
- let ids_to_father_ids = Hashtbl.create 503 in
- let ids_to_inner_sorts = Hashtbl.create 503 in
- let ids_to_inner_types = Hashtbl.create 503 in
- let ids_to_hypotheses = Hashtbl.create 23 in
- let hypotheses_seed = ref 0 in
- let seed = ref 1 in (* 'i0' is used for the whole sequent *)
- let unsh_sequent =
- let i,canonical_context,term = sequent in
- let canonical_context' =
- List.fold_right
- (fun d canonical_context' ->
- let d =
- match d with
- None -> None
- | Some (n, Cic.Decl t)->
- Some (n, Cic.Decl (Unshare.unshare t))
- | Some (n, Cic.Def (t,None)) ->
- Some (n, Cic.Def ((Unshare.unshare t),None))
- | Some (n,Cic.Def (bo,Some ty)) ->
- Some (n, Cic.Def (Unshare.unshare bo,Some (Unshare.unshare ty)))
- in
- d::canonical_context'
- ) canonical_context []
- in
- let term' = Unshare.unshare term in
- (i,canonical_context',term')
- in
- let (metano,acontext,agoal) =
- aconjecture_of_conjecture seed ids_to_terms ids_to_father_ids
- ids_to_inner_sorts ids_to_inner_types ids_to_hypotheses hypotheses_seed
- metasenv unsh_sequent in
- (unsh_sequent,
- (("i0",metano,acontext,agoal),
- ids_to_terms,ids_to_father_ids,ids_to_inner_sorts,ids_to_hypotheses))
-;;
-
-let acic_object_of_cic_object ?(eta_fix=true) obj =
- let module C = Cic in
- let module E = Eta_fixing in
- let ids_to_terms = Hashtbl.create 503 in
- let ids_to_father_ids = Hashtbl.create 503 in
- let ids_to_inner_sorts = Hashtbl.create 503 in
- let ids_to_inner_types = Hashtbl.create 503 in
- let ids_to_conjectures = Hashtbl.create 11 in
- let ids_to_hypotheses = Hashtbl.create 127 in
- let hypotheses_seed = ref 0 in
- let conjectures_seed = ref 0 in
- let seed = ref 0 in
- let acic_term_of_cic_term_context' =
- acic_of_cic_context' seed ids_to_terms ids_to_father_ids ids_to_inner_sorts
- ids_to_inner_types in
- let acic_term_of_cic_term' = acic_term_of_cic_term_context' [] [] [] in
- let aconjecture_of_conjecture' = aconjecture_of_conjecture seed
- ids_to_terms ids_to_father_ids ids_to_inner_sorts ids_to_inner_types
- ids_to_hypotheses hypotheses_seed in
- let eta_fix metasenv context t =
- let t = if eta_fix then E.eta_fix metasenv context t else t in
- Unshare.unshare t in
- let aobj =
- match obj with
- C.Constant (id,Some bo,ty,params,attrs) ->
- let bo' = eta_fix [] [] bo in
- let ty' = eta_fix [] [] ty in
- let abo = acic_term_of_cic_term' ~computeinnertypes:true bo' (Some ty') in
- let aty = acic_term_of_cic_term' ~computeinnertypes:false ty' None in
- C.AConstant
- ("mettereaposto",Some "mettereaposto2",id,Some abo,aty,params,attrs)
- | C.Constant (id,None,ty,params,attrs) ->
- let ty' = eta_fix [] [] ty in
- let aty = acic_term_of_cic_term' ~computeinnertypes:false ty' None in
- C.AConstant
- ("mettereaposto",None,id,None,aty,params,attrs)
- | C.Variable (id,bo,ty,params,attrs) ->
- let ty' = eta_fix [] [] ty in
- let abo =
- match bo with
- None -> None
- | Some bo ->
- let bo' = eta_fix [] [] bo in
- Some (acic_term_of_cic_term' ~computeinnertypes:true bo' (Some ty'))
- in
- let aty = acic_term_of_cic_term' ~computeinnertypes:false ty' None in
- C.AVariable
- ("mettereaposto",id,abo,aty,params,attrs)
- | C.CurrentProof (id,conjectures,bo,ty,params,attrs) ->
- let conjectures' =
- List.map
- (function (i,canonical_context,term) ->
- let canonical_context' =
- List.fold_right
- (fun d canonical_context' ->
- let d =
- match d with
- None -> None
- | Some (n, C.Decl t)->
- Some (n, C.Decl (eta_fix conjectures canonical_context' t))
- | Some (n, C.Def (t,None)) ->
- Some (n,
- C.Def ((eta_fix conjectures canonical_context' t),None))
- | Some (_,C.Def (_,Some _)) -> assert false
- in
- d::canonical_context'
- ) canonical_context []
- in
- let term' = eta_fix conjectures canonical_context' term in
- (i,canonical_context',term')
- ) conjectures
- in
- let aconjectures =
- List.map
- (function (i,canonical_context,term) as conjecture ->
- let cid = "c" ^ string_of_int !conjectures_seed in
- xxx_add ids_to_conjectures cid conjecture ;
- incr conjectures_seed ;
- let (i,acanonical_context,aterm)
- = aconjecture_of_conjecture' conjectures conjecture in
- (cid,i,acanonical_context,aterm))
- conjectures' in
-(* let time1 = Sys.time () in *)
- let bo' = eta_fix conjectures' [] bo in
- let ty' = eta_fix conjectures' [] ty in
-(*
- let time2 = Sys.time () in
- prerr_endline
- ("++++++++++ Tempi della eta_fix: "^ string_of_float (time2 -. time1)) ;
- hashtbl_add_time := 0.0 ;
- type_of_aux'_add_time := 0.0 ;
- DoubleTypeInference.syntactic_equality_add_time := 0.0 ;
-*)
- let abo =
- acic_term_of_cic_term_context' ~computeinnertypes:true conjectures' [] [] bo' (Some ty') in
- let aty = acic_term_of_cic_term_context' ~computeinnertypes:false conjectures' [] [] ty' None in
-(*
- let time3 = Sys.time () in
- prerr_endline
- ("++++++++++++ Tempi della hashtbl_add_time: " ^ string_of_float !hashtbl_add_time) ;
- prerr_endline
- ("++++++++++++ Tempi della type_of_aux'_add_time(" ^ string_of_int !number_new_type_of_aux' ^ "): " ^ string_of_float !type_of_aux'_add_time) ;
- prerr_endline
- ("++++++++++++ Tempi della type_of_aux'_add_time nella double_type_inference(" ^ string_of_int !DoubleTypeInference.number_new_type_of_aux'_double_work ^ ";" ^ string_of_int !DoubleTypeInference.number_new_type_of_aux'_prop ^ "/" ^ string_of_int !DoubleTypeInference.number_new_type_of_aux' ^ "): " ^ string_of_float !DoubleTypeInference.type_of_aux'_add_time) ;
- prerr_endline
- ("++++++++++++ Tempi della syntactic_equality_add_time: " ^ string_of_float !DoubleTypeInference.syntactic_equality_add_time) ;
- prerr_endline
- ("++++++++++ Tempi della acic_of_cic: " ^ string_of_float (time3 -. time2)) ;
- prerr_endline
- ("++++++++++ Numero di iterazioni della acic_of_cic: " ^ string_of_int !seed) ;
-*)
- C.ACurrentProof
- ("mettereaposto","mettereaposto2",id,aconjectures,abo,aty,params,attrs)
- | C.InductiveDefinition (tys,params,paramsno,attrs) ->
- let tys =
- List.map
- (fun (name,i,arity,cl) ->
- (name,i,Unshare.unshare arity,
- List.map (fun (name,ty) -> name,Unshare.unshare ty) cl)) tys in
- let context =
- List.map
- (fun (name,_,arity,_) ->
- Some (C.Name name, C.Decl (Unshare.unshare arity))) tys in
- let idrefs = List.map (function _ -> gen_id seed) tys in
- let atys =
- List.map2
- (fun id (name,inductive,ty,cons) ->
- let acons =
- List.map
- (function (name,ty) ->
- (name,
- acic_term_of_cic_term_context' ~computeinnertypes:false [] context idrefs ty None)
- ) cons
- in
- (id,name,inductive,
- acic_term_of_cic_term' ~computeinnertypes:false ty None,acons)
- ) (List.rev idrefs) tys
- in
- C.AInductiveDefinition ("mettereaposto",atys,params,paramsno,attrs)
- in
- aobj,ids_to_terms,ids_to_father_ids,ids_to_inner_sorts,ids_to_inner_types,
- ids_to_conjectures,ids_to_hypotheses
-;;
-
-let plain_acic_term_of_cic_term =
- let module C = Cic in
- let mk_fresh_id =
- let id = ref 0 in
- function () -> incr id; "i" ^ string_of_int !id in
- let rec aux context t =
- let fresh_id = mk_fresh_id () in
- match t with
- C.Rel n ->
- let idref,id =
- match get_nth context n with
- idref,(Some (C.Name s,_)) -> idref,s
- | idref,_ -> idref,"__" ^ string_of_int n
- in
- C.ARel (fresh_id, idref, n, id)
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map
- (function i,t -> i, (aux context t)) exp_named_subst
- in
- C.AVar (fresh_id,uri,exp_named_subst')
- | C.Implicit _
- | C.Meta _ -> assert false
- | C.Sort s -> C.ASort (fresh_id, s)
- | C.Cast (v,t) ->
- C.ACast (fresh_id, aux context v, aux context t)
- | C.Prod (n,s,t) ->
- C.AProd
- (fresh_id, n, aux context s,
- aux ((fresh_id, Some (n, C.Decl s))::context) t)
- | C.Lambda (n,s,t) ->
- C.ALambda
- (fresh_id,n, aux context s,
- aux ((fresh_id, Some (n, C.Decl s))::context) t)
- | C.LetIn (n,s,t) ->
- C.ALetIn
- (fresh_id, n, aux context s,
- aux ((fresh_id, Some (n, C.Def(s,None)))::context) t)
- | C.Appl l ->
- C.AAppl (fresh_id, List.map (aux context) l)
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map
- (function i,t -> i, (aux context t)) exp_named_subst
- in
- C.AConst (fresh_id, uri, exp_named_subst')
- | C.MutInd (uri,tyno,exp_named_subst) ->
- let exp_named_subst' =
- List.map
- (function i,t -> i, (aux context t)) exp_named_subst
- in
- C.AMutInd (fresh_id, uri, tyno, exp_named_subst')
- | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
- let exp_named_subst' =
- List.map
- (function i,t -> i, (aux context t)) exp_named_subst
- in
- C.AMutConstruct (fresh_id, uri, tyno, consno, exp_named_subst')
- | C.MutCase (uri, tyno, outty, term, patterns) ->
- C.AMutCase (fresh_id, uri, tyno, aux context outty,
- aux context term, List.map (aux context) patterns)
- | C.Fix (funno, funs) ->
- let tys =
- List.map
- (fun (name,_,ty,_) -> mk_fresh_id (), Some (C.Name name, C.Decl ty)) funs
- in
- C.AFix (fresh_id, funno,
- List.map2
- (fun (id,_) (name, indidx, ty, bo) ->
- (id, name, indidx, aux context ty, aux (tys@context) bo)
- ) tys funs
- )
- | C.CoFix (funno, funs) ->
- let tys =
- List.map (fun (name,ty,_) ->
- mk_fresh_id (),Some (C.Name name, C.Decl ty)) funs
- in
- C.ACoFix (fresh_id, funno,
- List.map2
- (fun (id,_) (name, ty, bo) ->
- (id, name, aux context ty, aux (tys@context) bo)
- ) tys funs
- )
- in
- aux
-;;
-
-let plain_acic_object_of_cic_object obj =
- let module C = Cic in
- let mk_fresh_id =
- let id = ref 0 in
- function () -> incr id; "it" ^ string_of_int !id
- in
- match obj with
- C.Constant (id,Some bo,ty,params,attrs) ->
- let abo = plain_acic_term_of_cic_term [] bo in
- let aty = plain_acic_term_of_cic_term [] ty in
- C.AConstant
- ("mettereaposto",Some "mettereaposto2",id,Some abo,aty,params,attrs)
- | C.Constant (id,None,ty,params,attrs) ->
- let aty = plain_acic_term_of_cic_term [] ty in
- C.AConstant
- ("mettereaposto",None,id,None,aty,params,attrs)
- | C.Variable (id,bo,ty,params,attrs) ->
- let abo =
- match bo with
- None -> None
- | Some bo -> Some (plain_acic_term_of_cic_term [] bo)
- in
- let aty = plain_acic_term_of_cic_term [] ty in
- C.AVariable
- ("mettereaposto",id,abo,aty,params,attrs)
- | C.CurrentProof _ -> assert false
- | C.InductiveDefinition (tys,params,paramsno,attrs) ->
- let context =
- List.map
- (fun (name,_,arity,_) ->
- mk_fresh_id (), Some (C.Name name, C.Decl arity)) tys in
- let atys =
- List.map2
- (fun (id,_) (name,inductive,ty,cons) ->
- let acons =
- List.map
- (function (name,ty) ->
- (name,
- plain_acic_term_of_cic_term context ty)
- ) cons
- in
- (id,name,inductive,plain_acic_term_of_cic_term [] ty,acons)
- ) context tys
- in
- C.AInductiveDefinition ("mettereaposto",atys,params,paramsno,attrs)
-;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception NotEnoughElements
-
-val source_id_of_id : string -> string
-
-type anntypes =
- {annsynthesized : Cic.annterm ; annexpected : Cic.annterm option}
-;;
-
-type sort_kind = [ `Prop | `Set | `Type of CicUniv.universe | `CProp ]
-
-val string_of_sort: sort_kind -> string
-(*val sort_of_string: string -> sort_kind*)
-val sort_of_sort: Cic.sort -> sort_kind
-
-val acic_object_of_cic_object :
- ?eta_fix: bool -> (* perform eta_fixing; default: true*)
- Cic.obj -> (* object *)
- Cic.annobj * (* annotated object *)
- (Cic.id, Cic.term) Hashtbl.t * (* ids_to_terms *)
- (Cic.id, Cic.id option) Hashtbl.t * (* ids_to_father_ids *)
- (Cic.id, sort_kind) Hashtbl.t * (* ids_to_inner_sorts *)
- (Cic.id, anntypes) Hashtbl.t * (* ids_to_inner_types *)
- (Cic.id, Cic.conjecture) Hashtbl.t * (* ids_to_conjectures *)
- (Cic.id, Cic.hypothesis) Hashtbl.t (* ids_to_hypotheses *)
-
-val asequent_of_sequent :
- Cic.metasenv -> (* metasenv *)
- Cic.conjecture -> (* sequent *)
- Cic.conjecture * (* unshared sequent *)
- (Cic.annconjecture * (* annotated sequent *)
- (Cic.id, Cic.term) Hashtbl.t * (* ids_to_terms *)
- (Cic.id, Cic.id option) Hashtbl.t * (* ids_to_father_ids *)
- (Cic.id, sort_kind) Hashtbl.t * (* ids_to_inner_sorts *)
- (Cic.id, Cic.hypothesis) Hashtbl.t) (* ids_to_hypotheses *)
-
-val plain_acic_object_of_cic_object : Cic.obj -> Cic.annobj
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(**************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 16/6/2003 *)
-(* *)
-(**************************************************************************)
-
-let object_prefix = "obj:";;
-let declaration_prefix = "decl:";;
-let definition_prefix = "def:";;
-let inductive_prefix = "ind:";;
-let joint_prefix = "joint:";;
-let proof_prefix = "proof:";;
-let conclude_prefix = "concl:";;
-let premise_prefix = "prem:";;
-let lemma_prefix = "lemma:";;
-
-(* e se mettessi la conversione di BY nell'apply_context ? *)
-(* sarebbe carino avere l'invariante che la proof2pres
-generasse sempre prove con contesto vuoto *)
-
-let gen_id prefix seed =
- let res = prefix ^ string_of_int !seed in
- incr seed ;
- res
-;;
-
-let name_of = function
- Cic.Anonymous -> None
- | Cic.Name b -> Some b;;
-
-exception Not_a_proof;;
-exception NotImplemented;;
-exception NotApplicable;;
-
-(* we do not care for positivity, here, that in any case is enforced by
- well typing. Just a brutal search *)
-
-let rec occur uri =
- let module C = Cic in
- function
- C.Rel _ -> false
- | C.Var _ -> false
- | C.Meta _ -> false
- | C.Sort _ -> false
- | C.Implicit _ -> assert false
- | C.Prod (_,s,t) -> (occur uri s) or (occur uri t)
- | C.Cast (te,ty) -> (occur uri te)
- | C.Lambda (_,s,t) -> (occur uri s) or (occur uri t) (* or false ?? *)
- | C.LetIn (_,s,t) -> (occur uri s) or (occur uri t)
- | C.Appl l ->
- List.fold_left
- (fun b a ->
- if b then b
- else (occur uri a)) false l
- | C.Const (_,_) -> false
- | C.MutInd (uri1,_,_) -> if uri = uri1 then true else false
- | C.MutConstruct (_,_,_,_) -> false
- | C.MutCase _ -> false (* presuming too much?? *)
- | C.Fix _ -> false (* presuming too much?? *)
- | C.CoFix (_,_) -> false (* presuming too much?? *)
-;;
-
-let get_id =
- let module C = Cic in
- function
- C.ARel (id,_,_,_) -> id
- | C.AVar (id,_,_) -> id
- | C.AMeta (id,_,_) -> id
- | C.ASort (id,_) -> id
- | C.AImplicit _ -> raise NotImplemented
- | C.AProd (id,_,_,_) -> id
- | C.ACast (id,_,_) -> id
- | C.ALambda (id,_,_,_) -> id
- | C.ALetIn (id,_,_,_) -> id
- | C.AAppl (id,_) -> id
- | C.AConst (id,_,_) -> id
- | C.AMutInd (id,_,_,_) -> id
- | C.AMutConstruct (id,_,_,_,_) -> id
- | C.AMutCase (id,_,_,_,_,_) -> id
- | C.AFix (id,_,_) -> id
- | C.ACoFix (id,_,_) -> id
-;;
-
-let test_for_lifting ~ids_to_inner_types ~ids_to_inner_sorts=
- let module C = Cic in
- let module C2A = Cic2acic in
- (* atomic terms are never lifted, according to my policy *)
- function
- C.ARel (id,_,_,_) -> false
- | C.AVar (id,_,_) ->
- (try
- ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
- true;
- with Not_found -> false)
- | C.AMeta (id,_,_) ->
- (try
- Hashtbl.find ids_to_inner_sorts id = `Prop
- with Not_found -> assert false)
- | C.ASort (id,_) -> false
- | C.AImplicit _ -> raise NotImplemented
- | C.AProd (id,_,_,_) -> false
- | C.ACast (id,_,_) ->
- (try
- ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
- true;
- with Not_found -> false)
- | C.ALambda (id,_,_,_) ->
- (try
- ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
- true;
- with Not_found -> false)
- | C.ALetIn (id,_,_,_) ->
- (try
- ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
- true;
- with Not_found -> false)
- | C.AAppl (id,_) ->
- (try
- ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
- true;
- with Not_found -> false)
- | C.AConst (id,_,_) ->
- (try
- ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
- true;
- with Not_found -> false)
- | C.AMutInd (id,_,_,_) -> false
- | C.AMutConstruct (id,_,_,_,_) ->
- (try
- ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
- true;
- with Not_found -> false)
- (* oppure: false *)
- | C.AMutCase (id,_,_,_,_,_) ->
- (try
- ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
- true;
- with Not_found -> false)
- | C.AFix (id,_,_) ->
- (try
- ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
- true;
- with Not_found -> false)
- | C.ACoFix (id,_,_) ->
- (try
- ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized;
- true;
- with Not_found -> false)
-;;
-
-(* transform a proof p into a proof list, concatenating the last
-conclude element to the apply_context list, in case context is
-empty. Otherwise, it just returns [p] *)
-
-let flat seed p =
- let module K = Content in
- if (p.K.proof_context = []) then
- if p.K.proof_apply_context = [] then [p]
- else
- let p1 =
- { p with
- K.proof_context = [];
- K.proof_apply_context = []
- } in
- p.K.proof_apply_context@[p1]
- else
- [p]
-;;
-
-let rec serialize seed =
- function
- [] -> []
- | a::l -> (flat seed a)@(serialize seed l)
-;;
-
-(* top_down = true if the term is a LAMBDA or a decl *)
-let generate_conversion seed top_down id inner_proof ~ids_to_inner_types =
- let module C2A = Cic2acic in
- let module K = Content in
- let exp = (try ((Hashtbl.find ids_to_inner_types id).C2A.annexpected)
- with Not_found -> None)
- in
- match exp with
- None -> inner_proof
- | Some expty ->
- if inner_proof.K.proof_conclude.K.conclude_method = "Intros+LetTac" then
- { K.proof_name = inner_proof.K.proof_name;
- K.proof_id = gen_id proof_prefix seed;
- K.proof_context = [] ;
- K.proof_apply_context = [];
- K.proof_conclude =
- { K.conclude_id = gen_id conclude_prefix seed;
- K.conclude_aref = id;
- K.conclude_method = "TD_Conversion";
- K.conclude_args =
- [K.ArgProof {inner_proof with K.proof_name = None}];
- K.conclude_conclusion = Some expty
- };
- }
- else
- { K.proof_name = inner_proof.K.proof_name;
- K.proof_id = gen_id proof_prefix seed;
- K.proof_context = [] ;
- K.proof_apply_context = [{inner_proof with K.proof_name = None}];
- K.proof_conclude =
- { K.conclude_id = gen_id conclude_prefix seed;
- K.conclude_aref = id;
- K.conclude_method = "BU_Conversion";
- K.conclude_args =
- [K.Premise
- { K.premise_id = gen_id premise_prefix seed;
- K.premise_xref = inner_proof.K.proof_id;
- K.premise_binder = None;
- K.premise_n = None
- }
- ];
- K.conclude_conclusion = Some expty
- };
- }
-;;
-
-let generate_exact seed t id name ~ids_to_inner_types =
- let module C2A = Cic2acic in
- let module K = Content in
- { K.proof_name = name;
- K.proof_id = gen_id proof_prefix seed ;
- K.proof_context = [] ;
- K.proof_apply_context = [];
- K.proof_conclude =
- { K.conclude_id = gen_id conclude_prefix seed;
- K.conclude_aref = id;
- K.conclude_method = "Exact";
- K.conclude_args = [K.Term t];
- K.conclude_conclusion =
- try Some (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
- with Not_found -> None
- };
- }
-;;
-
-let generate_intros_let_tac seed id n s is_intro inner_proof name ~ids_to_inner_types =
- let module C2A = Cic2acic in
- let module C = Cic in
- let module K = Content in
- { K.proof_name = name;
- K.proof_id = gen_id proof_prefix seed ;
- K.proof_context = [] ;
- K.proof_apply_context = [];
- K.proof_conclude =
- { K.conclude_id = gen_id conclude_prefix seed;
- K.conclude_aref = id;
- K.conclude_method = "Intros+LetTac";
- K.conclude_args = [K.ArgProof inner_proof];
- K.conclude_conclusion =
- try Some
- (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
- with Not_found ->
- (match inner_proof.K.proof_conclude.K.conclude_conclusion with
- None -> None
- | Some t ->
- if is_intro then Some (C.AProd ("gen"^id,n,s,t))
- else Some (C.ALetIn ("gen"^id,n,s,t)))
- };
- }
-;;
-
-let build_decl_item seed id n s ~ids_to_inner_sorts =
- let module K = Content in
- let sort =
- try
- Some (Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id))
- with Not_found -> None
- in
- match sort with
- | Some `Prop ->
- `Hypothesis
- { K.dec_name = name_of n;
- K.dec_id = gen_id declaration_prefix seed;
- K.dec_inductive = false;
- K.dec_aref = id;
- K.dec_type = s
- }
- | _ ->
- `Declaration
- { K.dec_name = name_of n;
- K.dec_id = gen_id declaration_prefix seed;
- K.dec_inductive = false;
- K.dec_aref = id;
- K.dec_type = s
- }
-;;
-
-let rec build_subproofs_and_args seed l ~ids_to_inner_types ~ids_to_inner_sorts =
- let module C = Cic in
- let module K = Content in
- let rec aux =
- function
- [] -> [],[]
- | t::l1 ->
- let subproofs,args = aux l1 in
- if (test_for_lifting t ~ids_to_inner_types ~ids_to_inner_sorts) then
- let new_subproof =
- acic2content
- seed ~name:"H" ~ids_to_inner_types ~ids_to_inner_sorts t in
- let new_arg =
- K.Premise
- { K.premise_id = gen_id premise_prefix seed;
- K.premise_xref = new_subproof.K.proof_id;
- K.premise_binder = new_subproof.K.proof_name;
- K.premise_n = None
- } in
- new_subproof::subproofs,new_arg::args
- else
- let hd =
- (match t with
- C.ARel (idr,idref,n,b) ->
- let sort =
- (try
- Hashtbl.find ids_to_inner_sorts idr
- with Not_found -> `Type (CicUniv.fresh())) in
- if sort = `Prop then
- K.Premise
- { K.premise_id = gen_id premise_prefix seed;
- K.premise_xref = idr;
- K.premise_binder = Some b;
- K.premise_n = Some n
- }
- else (K.Term t)
- | C.AConst(id,uri,[]) ->
- let sort =
- (try
- Hashtbl.find ids_to_inner_sorts id
- with Not_found -> `Type (CicUniv.fresh())) in
- if sort = `Prop then
- K.Lemma
- { K.lemma_id = gen_id lemma_prefix seed;
- K.lemma_name = UriManager.name_of_uri uri;
- K.lemma_uri = UriManager.string_of_uri uri
- }
- else (K.Term t)
- | C.AMutConstruct(id,uri,tyno,consno,[]) ->
- let sort =
- (try
- Hashtbl.find ids_to_inner_sorts id
- with Not_found -> `Type (CicUniv.fresh())) in
- if sort = `Prop then
- let inductive_types =
- (let o,_ =
- CicEnvironment.get_obj CicUniv.empty_ugraph uri
- in
- match o with
- | Cic.InductiveDefinition (l,_,_,_) -> l
- | _ -> assert false
- ) in
- let (_,_,_,constructors) =
- List.nth inductive_types tyno in
- let name,_ = List.nth constructors (consno - 1) in
- K.Lemma
- { K.lemma_id = gen_id lemma_prefix seed;
- K.lemma_name = name;
- K.lemma_uri =
- UriManager.string_of_uri uri ^ "#xpointer(1/" ^
- string_of_int (tyno+1) ^ "/" ^ string_of_int consno ^
- ")"
- }
- else (K.Term t)
- | _ -> (K.Term t)) in
- subproofs,hd::args
- in
- match (aux l) with
- [p],args ->
- [{p with K.proof_name = None}],
- List.map
- (function
- K.Premise prem when prem.K.premise_xref = p.K.proof_id ->
- K.Premise {prem with K.premise_binder = None}
- | i -> i) args
- | p,a as c -> c
-
-and
-
-build_def_item seed id n t ~ids_to_inner_sorts ~ids_to_inner_types =
- let module K = Content in
- try
- let sort = Hashtbl.find ids_to_inner_sorts id in
- if sort = `Prop then
- (let p =
- (acic2content seed ?name:(name_of n) ~ids_to_inner_sorts ~ids_to_inner_types t)
- in
- `Proof p;)
- else
- `Definition
- { K.def_name = name_of n;
- K.def_id = gen_id definition_prefix seed;
- K.def_aref = id;
- K.def_term = t
- }
- with
- Not_found -> assert false
-
-(* the following function must be called with an object of sort
-Prop. For debugging purposes this is tested again, possibly raising an
-Not_a_proof exception *)
-
-and acic2content seed ?name ~ids_to_inner_sorts ~ids_to_inner_types t =
- let rec aux ?name t =
- let module C = Cic in
- let module K = Content in
- let module C2A = Cic2acic in
- let t1 =
- match t with
- C.ARel (id,idref,n,b) as t ->
- let sort = Hashtbl.find ids_to_inner_sorts id in
- if sort = `Prop then
- generate_exact seed t id name ~ids_to_inner_types
- else raise Not_a_proof
- | C.AVar (id,uri,exp_named_subst) as t ->
- let sort = Hashtbl.find ids_to_inner_sorts id in
- if sort = `Prop then
- generate_exact seed t id name ~ids_to_inner_types
- else raise Not_a_proof
- | C.AMeta (id,n,l) as t ->
- let sort = Hashtbl.find ids_to_inner_sorts id in
- if sort = `Prop then
- generate_exact seed t id name ~ids_to_inner_types
- else raise Not_a_proof
- | C.ASort (id,s) -> raise Not_a_proof
- | C.AImplicit _ -> raise NotImplemented
- | C.AProd (_,_,_,_) -> raise Not_a_proof
- | C.ACast (id,v,t) -> aux v
- | C.ALambda (id,n,s,t) ->
- let sort = Hashtbl.find ids_to_inner_sorts id in
- if sort = `Prop then
- let proof = aux t in
- let proof' =
- if proof.K.proof_conclude.K.conclude_method = "Intros+LetTac" then
- match proof.K.proof_conclude.K.conclude_args with
- [K.ArgProof p] -> p
- | _ -> assert false
- else proof in
- let proof'' =
- { proof' with
- K.proof_name = None;
- K.proof_context =
- (build_decl_item seed id n s ids_to_inner_sorts)::
- proof'.K.proof_context
- }
- in
- generate_intros_let_tac seed id n s true proof'' name ~ids_to_inner_types
- else raise Not_a_proof
- | C.ALetIn (id,n,s,t) ->
- let sort = Hashtbl.find ids_to_inner_sorts id in
- if sort = `Prop then
- let proof = aux t in
- let proof' =
- if proof.K.proof_conclude.K.conclude_method = "Intros+LetTac" then
- match proof.K.proof_conclude.K.conclude_args with
- [K.ArgProof p] -> p
- | _ -> assert false
- else proof in
- let proof'' =
- { proof' with
- K.proof_name = None;
- K.proof_context =
- ((build_def_item seed id n s ids_to_inner_sorts
- ids_to_inner_types):> Cic.annterm K.in_proof_context_element)
- ::proof'.K.proof_context;
- }
- in
- generate_intros_let_tac seed id n s false proof'' name ~ids_to_inner_types
- else raise Not_a_proof
- | C.AAppl (id,li) ->
- (try rewrite
- seed name id li ~ids_to_inner_types ~ids_to_inner_sorts
- with NotApplicable ->
- try inductive
- seed name id li ~ids_to_inner_types ~ids_to_inner_sorts
- with NotApplicable ->
- let subproofs, args =
- build_subproofs_and_args
- seed li ~ids_to_inner_types ~ids_to_inner_sorts in
-(*
- let args_to_lift =
- List.filter (test_for_lifting ~ids_to_inner_types) li in
- let subproofs =
- match args_to_lift with
- [_] -> List.map aux args_to_lift
- | _ -> List.map (aux ~name:"H") args_to_lift in
- let args = build_args seed li subproofs
- ~ids_to_inner_types ~ids_to_inner_sorts in *)
- { K.proof_name = name;
- K.proof_id = gen_id proof_prefix seed;
- K.proof_context = [];
- K.proof_apply_context = serialize seed subproofs;
- K.proof_conclude =
- { K.conclude_id = gen_id conclude_prefix seed;
- K.conclude_aref = id;
- K.conclude_method = "Apply";
- K.conclude_args = args;
- K.conclude_conclusion =
- try Some
- (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
- with Not_found -> None
- };
- })
- | C.AConst (id,uri,exp_named_subst) as t ->
- let sort = Hashtbl.find ids_to_inner_sorts id in
- if sort = `Prop then
- generate_exact seed t id name ~ids_to_inner_types
- else raise Not_a_proof
- | C.AMutInd (id,uri,i,exp_named_subst) -> raise Not_a_proof
- | C.AMutConstruct (id,uri,i,j,exp_named_subst) as t ->
- let sort = Hashtbl.find ids_to_inner_sorts id in
- if sort = `Prop then
- generate_exact seed t id name ~ids_to_inner_types
- else raise Not_a_proof
- | C.AMutCase (id,uri,typeno,ty,te,patterns) ->
- let inductive_types,noparams =
- (let o, _ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- Cic.Constant _ -> assert false
- | Cic.Variable _ -> assert false
- | Cic.CurrentProof _ -> assert false
- | Cic.InductiveDefinition (l,_,n,_) -> l,n
- ) in
- let (_,_,_,constructors) = List.nth inductive_types typeno in
- let name_and_arities =
- let rec count_prods =
- function
- C.Prod (_,_,t) -> 1 + count_prods t
- | _ -> 0 in
- List.map
- (function (n,t) -> Some n,((count_prods t) - noparams)) constructors in
- let pp =
- let build_proof p (name,arity) =
- let rec make_context_and_body c p n =
- if n = 0 then c,(aux p)
- else
- (match p with
- Cic.ALambda(idl,vname,s1,t1) ->
- let ce =
- build_decl_item seed idl vname s1 ~ids_to_inner_sorts in
- make_context_and_body (ce::c) t1 (n-1)
- | _ -> assert false) in
- let context,body = make_context_and_body [] p arity in
- K.ArgProof
- {body with K.proof_name = name; K.proof_context=context} in
- List.map2 build_proof patterns name_and_arities in
- let teid = get_id te in
- let context,term =
- (match
- build_subproofs_and_args
- seed ~ids_to_inner_types ~ids_to_inner_sorts [te]
- with
- l,[t] -> l,t
- | _ -> assert false) in
- { K.proof_name = name;
- K.proof_id = gen_id proof_prefix seed;
- K.proof_context = [];
- K.proof_apply_context = serialize seed context;
- K.proof_conclude =
- { K.conclude_id = gen_id conclude_prefix seed;
- K.conclude_aref = id;
- K.conclude_method = "Case";
- K.conclude_args =
- (K.Aux (UriManager.string_of_uri uri))::
- (K.Aux (string_of_int typeno))::(K.Term ty)::term::pp;
- K.conclude_conclusion =
- try Some
- (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
- with Not_found -> None
- }
- }
- | C.AFix (id, no, funs) ->
- let proofs =
- List.map
- (function (_,name,_,_,bo) -> `Proof (aux ~name bo)) funs in
- let fun_name =
- List.nth (List.map (fun (_,name,_,_,_) -> name) funs) no
- in
- let decreasing_args =
- List.map (function (_,_,n,_,_) -> n) funs in
- let jo =
- { K.joint_id = gen_id joint_prefix seed;
- K.joint_kind = `Recursive decreasing_args;
- K.joint_defs = proofs
- }
- in
- { K.proof_name = name;
- K.proof_id = gen_id proof_prefix seed;
- K.proof_context = [`Joint jo];
- K.proof_apply_context = [];
- K.proof_conclude =
- { K.conclude_id = gen_id conclude_prefix seed;
- K.conclude_aref = id;
- K.conclude_method = "Exact";
- K.conclude_args =
- [ K.Premise
- { K.premise_id = gen_id premise_prefix seed;
- K.premise_xref = jo.K.joint_id;
- K.premise_binder = Some fun_name;
- K.premise_n = Some no;
- }
- ];
- K.conclude_conclusion =
- try Some
- (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
- with Not_found -> None
- }
- }
- | C.ACoFix (id,no,funs) ->
- let proofs =
- List.map
- (function (_,name,_,bo) -> `Proof (aux ~name bo)) funs in
- let jo =
- { K.joint_id = gen_id joint_prefix seed;
- K.joint_kind = `CoRecursive;
- K.joint_defs = proofs
- }
- in
- { K.proof_name = name;
- K.proof_id = gen_id proof_prefix seed;
- K.proof_context = [`Joint jo];
- K.proof_apply_context = [];
- K.proof_conclude =
- { K.conclude_id = gen_id conclude_prefix seed;
- K.conclude_aref = id;
- K.conclude_method = "Exact";
- K.conclude_args =
- [ K.Premise
- { K.premise_id = gen_id premise_prefix seed;
- K.premise_xref = jo.K.joint_id;
- K.premise_binder = Some "tiralo fuori";
- K.premise_n = Some no;
- }
- ];
- K.conclude_conclusion =
- try Some
- (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
- with Not_found -> None
- };
- }
- in
- let id = get_id t in
- generate_conversion seed false id t1 ~ids_to_inner_types
-in aux ?name t
-
-and inductive seed name id li ~ids_to_inner_types ~ids_to_inner_sorts =
- let aux ?name = acic2content seed ~ids_to_inner_types ~ids_to_inner_sorts in
- let module C2A = Cic2acic in
- let module K = Content in
- let module C = Cic in
- match li with
- C.AConst (idc,uri,exp_named_subst)::args ->
- let uri_str = UriManager.string_of_uri uri in
- let suffix = Str.regexp_string "_ind.con" in
- let len = String.length uri_str in
- let n = (try (Str.search_backward suffix uri_str len)
- with Not_found -> -1) in
- if n<0 then raise NotApplicable
- else
- let method_name =
- if UriManager.eq uri HelmLibraryObjects.Logic.ex_ind_URI then "Exists"
- else if UriManager.eq uri HelmLibraryObjects.Logic.and_ind_URI then "AndInd"
- else if UriManager.eq uri HelmLibraryObjects.Logic.false_ind_URI then "FalseInd"
- else "ByInduction" in
- let prefix = String.sub uri_str 0 n in
- let ind_str = (prefix ^ ".ind") in
- let ind_uri = UriManager.uri_of_string ind_str in
- let inductive_types,noparams =
- (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph ind_uri in
- match o with
- | Cic.InductiveDefinition (l,_,n,_) -> (l,n)
- | _ -> assert false
- ) in
- let rec split n l =
- if n = 0 then ([],l) else
- let p,a = split (n-1) (List.tl l) in
- ((List.hd l::p),a) in
- let params_and_IP,tail_args = split (noparams+1) args in
- let constructors =
- (match inductive_types with
- [(_,_,_,l)] -> l
- | _ -> raise NotApplicable) (* don't care for mutual ind *) in
- let constructors1 =
- let rec clean_up n t =
- if n = 0 then t else
- (match t with
- (label,Cic.Prod (_,_,t)) -> clean_up (n-1) (label,t)
- | _ -> assert false) in
- List.map (clean_up noparams) constructors in
- let no_constructors= List.length constructors in
- let args_for_cases, other_args =
- split no_constructors tail_args in
- let subproofs,other_method_args =
- build_subproofs_and_args seed other_args
- ~ids_to_inner_types ~ids_to_inner_sorts in
- let method_args=
- let rec build_method_args =
- function
- [],_-> [] (* extra args are ignored ???? *)
- | (name,ty)::tlc,arg::tla ->
- let idarg = get_id arg in
- let sortarg =
- (try (Hashtbl.find ids_to_inner_sorts idarg)
- with Not_found -> `Type (CicUniv.fresh())) in
- let hdarg =
- if sortarg = `Prop then
- let (co,bo) =
- let rec bc =
- function
- Cic.Prod (_,s,t),Cic.ALambda(idl,n,s1,t1) ->
- let ce =
- build_decl_item
- seed idl n s1 ~ids_to_inner_sorts in
- if (occur ind_uri s) then
- ( match t1 with
- Cic.ALambda(id2,n2,s2,t2) ->
- let inductive_hyp =
- `Hypothesis
- { K.dec_name = name_of n2;
- K.dec_id =
- gen_id declaration_prefix seed;
- K.dec_inductive = true;
- K.dec_aref = id2;
- K.dec_type = s2
- } in
- let (context,body) = bc (t,t2) in
- (ce::inductive_hyp::context,body)
- | _ -> assert false)
- else
- (
- let (context,body) = bc (t,t1) in
- (ce::context,body))
- | _ , t -> ([],aux t) in
- bc (ty,arg) in
- K.ArgProof
- { bo with
- K.proof_name = Some name;
- K.proof_context = co;
- };
- else (K.Term arg) in
- hdarg::(build_method_args (tlc,tla))
- | _ -> assert false in
- build_method_args (constructors1,args_for_cases) in
- { K.proof_name = name;
- K.proof_id = gen_id proof_prefix seed;
- K.proof_context = [];
- K.proof_apply_context = serialize seed subproofs;
- K.proof_conclude =
- { K.conclude_id = gen_id conclude_prefix seed;
- K.conclude_aref = id;
- K.conclude_method = method_name;
- K.conclude_args =
- K.Aux (string_of_int no_constructors)
- ::K.Term (C.AAppl(id,((C.AConst(idc,uri,exp_named_subst))::params_and_IP)))
- ::method_args@other_method_args;
- K.conclude_conclusion =
- try Some
- (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
- with Not_found -> None
- }
- }
- | _ -> raise NotApplicable
-
-and rewrite seed name id li ~ids_to_inner_types ~ids_to_inner_sorts =
- let aux ?name = acic2content seed ~ids_to_inner_types ~ids_to_inner_sorts in
- let module C2A = Cic2acic in
- let module K = Content in
- let module C = Cic in
- match li with
- C.AConst (sid,uri,exp_named_subst)::args ->
- if UriManager.eq uri HelmLibraryObjects.Logic.eq_ind_URI or
- UriManager.eq uri HelmLibraryObjects.Logic.eq_ind_r_URI then
- let subproofs,arg =
- (match
- build_subproofs_and_args
- seed ~ids_to_inner_types ~ids_to_inner_sorts [List.nth args 3]
- with
- l,[p] -> l,p
- | _,_ -> assert false) in
- let method_args =
- let rec ma_aux n = function
- [] -> []
- | a::tl ->
- let hd =
- if n = 0 then arg
- else
- let aid = get_id a in
- let asort = (try (Hashtbl.find ids_to_inner_sorts aid)
- with Not_found -> `Type (CicUniv.fresh())) in
- if asort = `Prop then
- K.ArgProof (aux a)
- else K.Term a in
- hd::(ma_aux (n-1) tl) in
- (ma_aux 3 args) in
- { K.proof_name = name;
- K.proof_id = gen_id proof_prefix seed;
- K.proof_context = [];
- K.proof_apply_context = serialize seed subproofs;
- K.proof_conclude =
- { K.conclude_id = gen_id conclude_prefix seed;
- K.conclude_aref = id;
- K.conclude_method = "Rewrite";
- K.conclude_args =
- K.Term (C.AConst (sid,uri,exp_named_subst))::method_args;
- K.conclude_conclusion =
- try Some
- (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
- with Not_found -> None
- }
- }
- else raise NotApplicable
- | _ -> raise NotApplicable
-;;
-
-let map_conjectures
- seed ~ids_to_inner_sorts ~ids_to_inner_types (id,n,context,ty)
-=
- let module K = Content in
- let context' =
- List.map
- (function
- (id,None) -> None
- | (id,Some (name,Cic.ADecl t)) ->
- Some
- (* We should call build_decl_item, but we have not computed *)
- (* the inner-types ==> we always produce a declaration *)
- (`Declaration
- { K.dec_name = name_of name;
- K.dec_id = gen_id declaration_prefix seed;
- K.dec_inductive = false;
- K.dec_aref = get_id t;
- K.dec_type = t
- })
- | (id,Some (name,Cic.ADef t)) ->
- Some
- (* We should call build_def_item, but we have not computed *)
- (* the inner-types ==> we always produce a declaration *)
- (`Definition
- { K.def_name = name_of name;
- K.def_id = gen_id definition_prefix seed;
- K.def_aref = get_id t;
- K.def_term = t
- })
- ) context
- in
- (id,n,context',ty)
-;;
-
-(* map_sequent is similar to map_conjectures, but the for the hid
-of the hypothesis, which are preserved instead of generating
-fresh ones. We shall have to adopt a uniform policy, soon or later *)
-
-let map_sequent ((id,n,context,ty):Cic.annconjecture) =
- let module K = Content in
- let context' =
- List.map
- (function
- (id,None) -> None
- | (id,Some (name,Cic.ADecl t)) ->
- Some
- (* We should call build_decl_item, but we have not computed *)
- (* the inner-types ==> we always produce a declaration *)
- (`Declaration
- { K.dec_name = name_of name;
- K.dec_id = id;
- K.dec_inductive = false;
- K.dec_aref = get_id t;
- K.dec_type = t
- })
- | (id,Some (name,Cic.ADef t)) ->
- Some
- (* We should call build_def_item, but we have not computed *)
- (* the inner-types ==> we always produce a declaration *)
- (`Definition
- { K.def_name = name_of name;
- K.def_id = id;
- K.def_aref = get_id t;
- K.def_term = t
- })
- ) context
- in
- (id,n,context',ty)
-;;
-
-let rec annobj2content ~ids_to_inner_sorts ~ids_to_inner_types =
- let module C = Cic in
- let module K = Content in
- let module C2A = Cic2acic in
- let seed = ref 0 in
- function
- C.ACurrentProof (_,_,n,conjectures,bo,ty,params,_) ->
- (gen_id object_prefix seed, params,
- Some
- (List.map
- (map_conjectures seed ~ids_to_inner_sorts ~ids_to_inner_types)
- conjectures),
- `Def (K.Const,ty,
- build_def_item seed (get_id bo) (C.Name n) bo
- ~ids_to_inner_sorts ~ids_to_inner_types))
- | C.AConstant (_,_,n,Some bo,ty,params,_) ->
- (gen_id object_prefix seed, params, None,
- `Def (K.Const,ty,
- build_def_item seed (get_id bo) (C.Name n) bo
- ~ids_to_inner_sorts ~ids_to_inner_types))
- | C.AConstant (id,_,n,None,ty,params,_) ->
- (gen_id object_prefix seed, params, None,
- `Decl (K.Const,
- build_decl_item seed id (C.Name n) ty
- ~ids_to_inner_sorts))
- | C.AVariable (_,n,Some bo,ty,params,_) ->
- (gen_id object_prefix seed, params, None,
- `Def (K.Var,ty,
- build_def_item seed (get_id bo) (C.Name n) bo
- ~ids_to_inner_sorts ~ids_to_inner_types))
- | C.AVariable (id,n,None,ty,params,_) ->
- (gen_id object_prefix seed, params, None,
- `Decl (K.Var,
- build_decl_item seed id (C.Name n) ty
- ~ids_to_inner_sorts))
- | C.AInductiveDefinition (id,l,params,nparams,_) ->
- (gen_id object_prefix seed, params, None,
- `Joint
- { K.joint_id = gen_id joint_prefix seed;
- K.joint_kind = `Inductive nparams;
- K.joint_defs = List.map (build_inductive seed) l
- })
-
-and
- build_inductive seed =
- let module K = Content in
- fun (_,n,b,ty,l) ->
- `Inductive
- { K.inductive_id = gen_id inductive_prefix seed;
- K.inductive_name = n;
- K.inductive_kind = b;
- K.inductive_type = ty;
- K.inductive_constructors = build_constructors seed l
- }
-
-and
- build_constructors seed l =
- let module K = Content in
- List.map
- (fun (n,t) ->
- { K.dec_name = Some n;
- K.dec_id = gen_id declaration_prefix seed;
- K.dec_inductive = false;
- K.dec_aref = "";
- K.dec_type = t
- }) l
-;;
-
-(*
-and 'term cinductiveType =
- id * string * bool * 'term * (* typename, inductive, arity *)
- 'term cconstructor list (* constructors *)
-
-and 'term cconstructor =
- string * 'term
-*)
-
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val annobj2content :
- ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t ->
- ids_to_inner_types:(Cic.id, Cic2acic.anntypes) Hashtbl.t ->
- Cic.annobj ->
- Cic.annterm Content.cobj
-
-val map_sequent :
- Cic.annconjecture -> Cic.annterm Content.conjecture
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(**************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 16/6/2003 *)
-(* *)
-(**************************************************************************)
-
-type id = string;;
-type joint_recursion_kind =
- [ `Recursive of int list
- | `CoRecursive
- | `Inductive of int (* paramsno *)
- | `CoInductive of int (* paramsno *)
- ]
-;;
-
-type var_or_const = Var | Const;;
-
-type 'term declaration =
- { dec_name : string option;
- dec_id : id ;
- dec_inductive : bool;
- dec_aref : string;
- dec_type : 'term
- }
-;;
-
-type 'term definition =
- { def_name : string option;
- def_id : id ;
- def_aref : string ;
- def_term : 'term
- }
-;;
-
-type 'term inductive =
- { inductive_id : id ;
- inductive_name : string;
- inductive_kind : bool;
- inductive_type : 'term;
- inductive_constructors : 'term declaration list
- }
-;;
-
-type 'term decl_context_element =
- [ `Declaration of 'term declaration
- | `Hypothesis of 'term declaration
- ]
-;;
-
-type ('term,'proof) def_context_element =
- [ `Proof of 'proof
- | `Definition of 'term definition
- ]
-;;
-
-type ('term,'proof) in_joint_context_element =
- [ `Inductive of 'term inductive
- | 'term decl_context_element
- | ('term,'proof) def_context_element
- ]
-;;
-
-type ('term,'proof) joint =
- { joint_id : id ;
- joint_kind : joint_recursion_kind ;
- joint_defs : ('term,'proof) in_joint_context_element list
- }
-;;
-
-type ('term,'proof) joint_context_element =
- [ `Joint of ('term,'proof) joint ]
-;;
-
-type 'term proof =
- { proof_name : string option;
- proof_id : id ;
- proof_context : 'term in_proof_context_element list ;
- proof_apply_context: 'term proof list;
- proof_conclude : 'term conclude_item
- }
-
-and 'term in_proof_context_element =
- [ 'term decl_context_element
- | ('term,'term proof) def_context_element
- | ('term,'term proof) joint_context_element
- ]
-
-and 'term conclude_item =
- { conclude_id : id;
- conclude_aref : string;
- conclude_method : string;
- conclude_args : ('term arg) list ;
- conclude_conclusion : 'term option
- }
-
-and 'term arg =
- Aux of string
- | Premise of premise
- | Lemma of lemma
- | Term of 'term
- | ArgProof of 'term proof
- | ArgMethod of string (* ???? *)
-
-and premise =
- { premise_id: id;
- premise_xref : string ;
- premise_binder : string option;
- premise_n : int option;
- }
-
-and lemma =
- { lemma_id: id;
- lemma_name: string;
- lemma_uri: string
- }
-
-;;
-
-type 'term conjecture = id * int * 'term context * 'term
-
-and 'term context = 'term hypothesis list
-
-and 'term hypothesis =
- ['term decl_context_element | ('term,'term proof) def_context_element ] option
-;;
-
-type 'term in_object_context_element =
- [ `Decl of var_or_const * 'term decl_context_element
- | `Def of var_or_const * 'term * ('term,'term proof) def_context_element
- | ('term,'term proof) joint_context_element
- ]
-;;
-
-type 'term cobj =
- id * (* id *)
- UriManager.uri list * (* params *)
- 'term conjecture list option * (* optional metasenv *)
- 'term in_object_context_element (* actual object *)
-;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type id = string;;
-type joint_recursion_kind =
- [ `Recursive of int list (* decreasing arguments *)
- | `CoRecursive
- | `Inductive of int (* paramsno *)
- | `CoInductive of int (* paramsno *)
- ]
-;;
-
-type var_or_const = Var | Const;;
-
-type 'term declaration =
- { dec_name : string option;
- dec_id : id ;
- dec_inductive : bool;
- dec_aref : string;
- dec_type : 'term
- }
-;;
-
-type 'term definition =
- { def_name : string option;
- def_id : id ;
- def_aref : string ;
- def_term : 'term
- }
-;;
-
-type 'term inductive =
- { inductive_id : id ;
- inductive_name : string;
- inductive_kind : bool;
- inductive_type : 'term;
- inductive_constructors : 'term declaration list
- }
-;;
-
-type 'term decl_context_element =
- [ `Declaration of 'term declaration
- | `Hypothesis of 'term declaration
- ]
-;;
-
-type ('term,'proof) def_context_element =
- [ `Proof of 'proof
- | `Definition of 'term definition
- ]
-;;
-
-type ('term,'proof) in_joint_context_element =
- [ `Inductive of 'term inductive
- | 'term decl_context_element
- | ('term,'proof) def_context_element
- ]
-;;
-
-type ('term,'proof) joint =
- { joint_id : id ;
- joint_kind : joint_recursion_kind ;
- joint_defs : ('term,'proof) in_joint_context_element list
- }
-;;
-
-type ('term,'proof) joint_context_element =
- [ `Joint of ('term,'proof) joint ]
-;;
-
-type 'term proof =
- { proof_name : string option;
- proof_id : id ;
- proof_context : 'term in_proof_context_element list ;
- proof_apply_context: 'term proof list;
- proof_conclude : 'term conclude_item
- }
-
-and 'term in_proof_context_element =
- [ 'term decl_context_element
- | ('term,'term proof) def_context_element
- | ('term,'term proof) joint_context_element
- ]
-
-and 'term conclude_item =
- { conclude_id : id;
- conclude_aref : string;
- conclude_method : string;
- conclude_args : ('term arg) list ;
- conclude_conclusion : 'term option
- }
-
-and 'term arg =
- Aux of string
- | Premise of premise
- | Lemma of lemma
- | Term of 'term
- | ArgProof of 'term proof
- | ArgMethod of string (* ???? *)
-
-and premise =
- { premise_id: id;
- premise_xref : string ;
- premise_binder : string option;
- premise_n : int option;
- }
-
-and lemma =
- { lemma_id: id;
- lemma_name : string;
- lemma_uri: string
- }
-;;
-
-type 'term conjecture = id * int * 'term context * 'term
-
-and 'term context = 'term hypothesis list
-
-and 'term hypothesis =
- ['term decl_context_element | ('term,'term proof) def_context_element ] option
-;;
-
-type 'term in_object_context_element =
- [ `Decl of var_or_const * 'term decl_context_element
- | `Def of var_or_const * 'term * ('term,'term proof) def_context_element
- | ('term,'term proof) joint_context_element
- ]
-;;
-
-type 'term cobj =
- id * (* id *)
- UriManager.uri list * (* params *)
- 'term conjecture list option * (* optional metasenv *)
- 'term in_object_context_element (* actual object *)
-;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(***************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 17/06/2003 *)
-(* *)
-(***************************************************************************)
-
-exception TO_DO;;
-
-let proof2cic deannotate p =
- let rec proof2cic premise_env p =
- let module C = Cic in
- let module Con = Content in
- let rec extend_premise_env current_env =
- function
- [] -> current_env
- | p::atl ->
- extend_premise_env
- ((p.Con.proof_id,(proof2cic current_env p))::current_env) atl in
- let new_premise_env = extend_premise_env premise_env p.Con.proof_apply_context in
- let body = conclude2cic new_premise_env p.Con.proof_conclude in
- context2cic premise_env p.Con.proof_context body
-
- and context2cic premise_env context body =
- List.fold_right (ce2cic premise_env) context body
-
- and ce2cic premise_env ce target =
- let module C = Cic in
- let module Con = Content in
- match ce with
- `Declaration d ->
- (match d.Con.dec_name with
- Some s ->
- C.Lambda (C.Name s, deannotate d.Con.dec_type, target)
- | None ->
- C.Lambda (C.Anonymous, deannotate d.Con.dec_type, target))
- | `Hypothesis h ->
- (match h.Con.dec_name with
- Some s ->
- C.Lambda (C.Name s, deannotate h.Con.dec_type, target)
- | None ->
- C.Lambda (C.Anonymous, deannotate h.Con.dec_type, target))
- | `Proof p ->
- (match p.Con.proof_name with
- Some s ->
- C.LetIn (C.Name s, proof2cic premise_env p, target)
- | None ->
- C.LetIn (C.Anonymous, proof2cic premise_env p, target))
- | `Definition d ->
- (match d.Con.def_name with
- Some s ->
- C.LetIn (C.Name s, proof2cic premise_env p, target)
- | None ->
- C.LetIn (C.Anonymous, proof2cic premise_env p, target))
- | `Joint {Con.joint_kind = kind; Con.joint_defs = defs} ->
- (match target with
- C.Rel n ->
- (match kind with
- `Recursive l ->
- let funs =
- List.map2
- (fun n bo ->
- match bo with
- `Proof bo ->
- (match
- bo.Con.proof_conclude.Con.conclude_conclusion,
- bo.Con.proof_name
- with
- Some ty, Some name ->
- (name,n,deannotate ty,
- proof2cic premise_env bo)
- | _,_ -> assert false)
- | _ -> assert false)
- l defs in
- C.Fix (n, funs)
- | `CoRecursive ->
- let funs =
- List.map
- (function bo ->
- match bo with
- `Proof bo ->
- (match
- bo.Con.proof_conclude.Con.conclude_conclusion,
- bo.Con.proof_name
- with
- Some ty, Some name ->
- (name,deannotate ty,
- proof2cic premise_env bo)
- | _,_ -> assert false)
- | _ -> assert false)
- defs in
- C.CoFix (n, funs)
- | _ -> (* no inductive types in local contexts *)
- assert false)
- | _ -> assert false)
-
- and conclude2cic premise_env conclude =
- let module C = Cic in
- let module Con = Content in
- if conclude.Con.conclude_method = "TD_Conversion" then
- (match conclude.Con.conclude_args with
- [Con.ArgProof p] -> proof2cic [] p (* empty! *)
- | _ -> prerr_endline "1"; assert false)
- else if conclude.Con.conclude_method = "BU_Conversion" then
- (match conclude.Con.conclude_args with
- [Con.Premise prem] ->
- (try List.assoc prem.Con.premise_xref premise_env
- with Not_found ->
- prerr_endline
- ("Not_found in BU_Conversion: " ^ prem.Con.premise_xref);
- raise Not_found)
- | _ -> prerr_endline "2"; assert false)
- else if conclude.Con.conclude_method = "Exact" then
- (match conclude.Con.conclude_args with
- [Con.Term t] -> deannotate t
- | [Con.Premise prem] ->
- (match prem.Con.premise_n with
- None -> assert false
- | Some n -> C.Rel n)
- | _ -> prerr_endline "3"; assert false)
- else if conclude.Con.conclude_method = "Intros+LetTac" then
- (match conclude.Con.conclude_args with
- [Con.ArgProof p] -> proof2cic [] p (* empty! *)
- | _ -> prerr_endline "4"; assert false)
- else if (conclude.Con.conclude_method = "ByInduction" ||
- conclude.Con.conclude_method = "AndInd" ||
- conclude.Con.conclude_method = "Exists" ||
- conclude.Con.conclude_method = "FalseInd") then
- (match (List.tl conclude.Con.conclude_args) with
- Con.Term (C.AAppl (
- id,((C.AConst(idc,uri,exp_named_subst))::params_and_IP)))::args ->
- let subst =
- List.map (fun (u,t) -> (u, deannotate t)) exp_named_subst in
- let cargs = args2cic premise_env args in
- let cparams_and_IP = List.map deannotate params_and_IP in
- C.Appl (C.Const(uri,subst)::cparams_and_IP@cargs)
- | _ -> prerr_endline "5"; assert false)
- else if (conclude.Con.conclude_method = "Rewrite") then
- (match conclude.Con.conclude_args with
- Con.Term (C.AConst (sid,uri,exp_named_subst))::args ->
- let subst =
- List.map (fun (u,t) -> (u, deannotate t)) exp_named_subst in
- let cargs = args2cic premise_env args in
- C.Appl (C.Const(uri,subst)::cargs)
- | _ -> prerr_endline "6"; assert false)
- else if (conclude.Con.conclude_method = "Case") then
- (match conclude.Con.conclude_args with
- Con.Aux(uri)::Con.Aux(notype)::Con.Term(ty)::Con.Premise(prem)::patterns ->
- C.MutCase
- (UriManager.uri_of_string uri,
- int_of_string notype, deannotate ty,
- List.assoc prem.Con.premise_xref premise_env,
- List.map
- (function
- Con.ArgProof p -> proof2cic [] p
- | _ -> prerr_endline "7a"; assert false) patterns)
- | Con.Aux(uri)::Con.Aux(notype)::Con.Term(ty)::Con.Term(te)::patterns -> C.MutCase
- (UriManager.uri_of_string uri,
- int_of_string notype, deannotate ty, deannotate te,
- List.map
- (function
- (Con.ArgProof p) -> proof2cic [] p
- | _ -> prerr_endline "7a"; assert false) patterns)
- | _ -> (prerr_endline "7"; assert false))
- else if (conclude.Con.conclude_method = "Apply") then
- let cargs = (args2cic premise_env conclude.Con.conclude_args) in
- C.Appl cargs
- else (prerr_endline "8"; assert false)
-
- and args2cic premise_env l =
- List.map (arg2cic premise_env) l
-
- and arg2cic premise_env =
- let module C = Cic in
- let module Con = Content in
- function
- Con.Aux n -> prerr_endline "8"; assert false
- | Con.Premise prem ->
- (match prem.Con.premise_n with
- Some n -> C.Rel n
- | None ->
- (try List.assoc prem.Con.premise_xref premise_env
- with Not_found ->
- prerr_endline ("Not_found in arg2cic: premise " ^ (match prem.Con.premise_binder with None -> "previous" | Some p -> p) ^ ", xref=" ^ prem.Con.premise_xref);
- raise Not_found))
- | Con.Lemma lemma ->
- CicUtil.term_of_uri (UriManager.uri_of_string lemma.Con.lemma_uri)
- | Con.Term t -> deannotate t
- | Con.ArgProof p -> proof2cic [] p (* empty! *)
- | Con.ArgMethod s -> raise TO_DO
-
-in proof2cic [] p
-;;
-
-exception ToDo;;
-
-let cobj2obj deannotate (id,params,metasenv,obj) =
- let module K = Content in
- match obj with
- `Def (Content.Const,ty,`Proof bo) ->
- (match metasenv with
- None ->
- Cic.Constant
- (id, Some (proof2cic deannotate bo), deannotate ty, params, [])
- | Some metasenv' ->
- let metasenv'' =
- List.map
- (function (_,i,canonical_context,term) ->
- let canonical_context' =
- List.map
- (function
- None -> None
- | Some (`Declaration d)
- | Some (`Hypothesis d) ->
- (match d with
- {K.dec_name = Some n ; K.dec_type = t} ->
- Some (Cic.Name n, Cic.Decl (deannotate t))
- | _ -> assert false)
- | Some (`Definition d) ->
- (match d with
- {K.def_name = Some n ; K.def_term = t} ->
- Some (Cic.Name n, Cic.Def ((deannotate t),None))
- | _ -> assert false)
- | Some (`Proof d) ->
- (match d with
- {K.proof_name = Some n } ->
- Some (Cic.Name n,
- Cic.Def ((proof2cic deannotate d),None))
- | _ -> assert false)
- ) canonical_context
- in
- (i,canonical_context',deannotate term)
- ) metasenv'
- in
- Cic.CurrentProof
- (id, metasenv'', proof2cic deannotate bo, deannotate ty, params,
- []))
- | _ -> raise ToDo
-;;
-
-let cobj2obj = cobj2obj Deannotate.deannotate_term;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(**************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 27/6/2003 *)
-(* *)
-(**************************************************************************)
-
-val cobj2obj : Cic.annterm Content.cobj -> Cic.obj
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(***************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 17/06/2003 *)
-(* *)
-(***************************************************************************)
-
-exception ContentPpInternalError;;
-exception NotEnoughElements;;
-exception TO_DO
-
-(* Utility functions *)
-
-
-let string_of_name =
- function
- Some s -> s
- | None -> "_"
-;;
-
-(* get_nth l n returns the nth element of the list l if it exists or *)
-(* raises NotEnoughElements if l has less than n elements *)
-let rec get_nth l n =
- match (n,l) with
- (1, he::_) -> he
- | (n, he::tail) when n > 1 -> get_nth tail (n-1)
- | (_,_) -> raise NotEnoughElements
-;;
-
-let rec blanks n =
- if n = 0 then ""
- else (" " ^ (blanks (n-1)));;
-
-let rec pproof (p: Cic.annterm Content.proof) indent =
- let module Con = Content in
- let new_indent =
- (match p.Con.proof_name with
- Some s ->
- prerr_endline
- ((blanks indent) ^ "(" ^ s ^ ")"); flush stderr ;(indent + 1)
- | None ->indent) in
- let new_indent1 =
- if (p.Con.proof_context = []) then new_indent
- else
- (pcontext p.Con.proof_context new_indent; (new_indent + 1)) in
- papply_context p.Con.proof_apply_context new_indent1;
- pconclude p.Con.proof_conclude new_indent1;
-
-and pcontext c indent =
- List.iter (pcontext_element indent) c
-
-and pcontext_element indent =
- let module Con = Content in
- function
- `Declaration d ->
- (match d.Con.dec_name with
- Some s ->
- prerr_endline
- ((blanks indent)
- ^ "Assume " ^ s ^ " : "
- ^ (CicPp.ppterm (Deannotate.deannotate_term d.Con.dec_type)));
- flush stderr
- | None ->
- prerr_endline ((blanks indent) ^ "NO NAME!!"))
- | `Hypothesis h ->
- (match h.Con.dec_name with
- Some s ->
- prerr_endline
- ((blanks indent)
- ^ "Suppose " ^ s ^ " : "
- ^ (CicPp.ppterm (Deannotate.deannotate_term h.Con.dec_type)));
- flush stderr
- | None ->
- prerr_endline ((blanks indent) ^ "NO NAME!!"))
- | `Proof p -> pproof p indent
- | `Definition d ->
- (match d.Con.def_name with
- Some s ->
- prerr_endline
- ((blanks indent) ^ "Let " ^ s ^ " = "
- ^ (CicPp.ppterm (Deannotate.deannotate_term d.Con.def_term)));
- flush stderr
- | None ->
- prerr_endline ((blanks indent) ^ "NO NAME!!"))
- | `Joint ho ->
- prerr_endline ((blanks indent) ^ "Joint Def");
- flush stderr
-
-and papply_context ac indent =
- List.iter(function p -> (pproof p indent)) ac
-
-and pconclude concl indent =
- let module Con = Content in
- prerr_endline ((blanks indent) ^ "Apply method " ^ concl.Con.conclude_method ^ " to");flush stderr;
- pargs concl.Con.conclude_args indent;
- match concl.Con.conclude_conclusion with
- None -> prerr_endline ((blanks indent) ^"No conclude conclusion");flush stderr
- | Some t -> prerr_endline ((blanks indent) ^ "conclude" ^ concl.Con.conclude_method ^ (CicPp.ppterm (Deannotate.deannotate_term t)));flush stderr
-
-and pargs args indent =
- List.iter (parg indent) args
-
-and parg indent =
- let module Con = Content in
- function
- Con.Aux n -> prerr_endline ((blanks (indent+1)) ^ n)
- | Con.Premise prem -> prerr_endline ((blanks (indent+1)) ^ "Premise")
- | Con.Lemma lemma -> prerr_endline ((blanks (indent+1)) ^ "Lemma")
- | Con.Term t ->
- prerr_endline ((blanks (indent+1)) ^ (CicPp.ppterm (Deannotate.deannotate_term t)))
- | Con.ArgProof p -> pproof p (indent+1)
- | Con.ArgMethod s -> prerr_endline ((blanks (indent+1)) ^ "A Method !!!")
-;;
-
-let print_proof p = pproof p 0;;
-
-let print_obj (_,_,_,obj) =
- match obj with
- `Decl (_,decl) ->
- pcontext_element 0 (decl:> Cic.annterm Content.in_proof_context_element)
- | `Def (_,_,def) ->
- pcontext_element 0 (def:> Cic.annterm Content.in_proof_context_element)
- | `Joint _ as jo -> pcontext_element 0 jo
-;;
-
-
-
-
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val print_proof: Cic.annterm Content.proof -> unit
-
-val print_obj: Cic.annterm Content.cobj -> unit
-
-val parg: int -> Cic.annterm Content.arg ->unit
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception Impossible of int;;
-exception NotWellTyped of string;;
-exception WrongUriToConstant of string;;
-exception WrongUriToVariable of string;;
-exception WrongUriToMutualInductiveDefinitions of string;;
-exception ListTooShort;;
-exception RelToHiddenHypothesis;;
-
-let syntactic_equality_add_time = ref 0.0;;
-let type_of_aux'_add_time = ref 0.0;;
-let number_new_type_of_aux'_double_work = ref 0;;
-let number_new_type_of_aux' = ref 0;;
-let number_new_type_of_aux'_prop = ref 0;;
-
-let double_work = ref 0;;
-
-let xxx_type_of_aux' m c t =
- let t1 = Sys.time () in
- let res,_ = CicTypeChecker.type_of_aux' m c t CicUniv.empty_ugraph in
- let t2 = Sys.time () in
- type_of_aux'_add_time := !type_of_aux'_add_time +. t2 -. t1 ;
- res
-;;
-
-type types = {synthesized : Cic.term ; expected : Cic.term option};;
-
-(* does_not_occur n te *)
-(* returns [true] if [Rel n] does not occur in [te] *)
-let rec does_not_occur n =
- let module C = Cic in
- function
- C.Rel m when m = n -> false
- | C.Rel _
- | C.Meta _
- | C.Sort _
- | C.Implicit _ -> true
- | C.Cast (te,ty) ->
- does_not_occur n te && does_not_occur n ty
- | C.Prod (name,so,dest) ->
- does_not_occur n so &&
- does_not_occur (n + 1) dest
- | C.Lambda (name,so,dest) ->
- does_not_occur n so &&
- does_not_occur (n + 1) dest
- | C.LetIn (name,so,dest) ->
- does_not_occur n so &&
- does_not_occur (n + 1) dest
- | C.Appl l ->
- List.fold_right (fun x i -> i && does_not_occur n x) l true
- | C.Var (_,exp_named_subst)
- | C.Const (_,exp_named_subst)
- | C.MutInd (_,_,exp_named_subst)
- | C.MutConstruct (_,_,_,exp_named_subst) ->
- List.fold_right (fun (_,x) i -> i && does_not_occur n x)
- exp_named_subst true
- | C.MutCase (_,_,out,te,pl) ->
- does_not_occur n out && does_not_occur n te &&
- List.fold_right (fun x i -> i && does_not_occur n x) pl true
- | C.Fix (_,fl) ->
- let len = List.length fl in
- let n_plus_len = n + len in
- let tys =
- List.map (fun (n,_,ty,_) -> Some (C.Name n,(Cic.Decl ty))) fl
- in
- List.fold_right
- (fun (_,_,ty,bo) i ->
- i && does_not_occur n ty &&
- does_not_occur n_plus_len bo
- ) fl true
- | C.CoFix (_,fl) ->
- let len = List.length fl in
- let n_plus_len = n + len in
- let tys =
- List.map (fun (n,ty,_) -> Some (C.Name n,(Cic.Decl ty))) fl
- in
- List.fold_right
- (fun (_,ty,bo) i ->
- i && does_not_occur n ty &&
- does_not_occur n_plus_len bo
- ) fl true
-;;
-
-let rec beta_reduce =
- let module S = CicSubstitution in
- let module C = Cic in
- function
- C.Rel _ as t -> t
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (i,t) -> i, beta_reduce t) exp_named_subst
- in
- C.Var (uri,exp_named_subst)
- | C.Meta (n,l) ->
- C.Meta (n,
- List.map
- (function None -> None | Some t -> Some (beta_reduce t)) l
- )
- | C.Sort _ as t -> t
- | C.Implicit _ -> assert false
- | C.Cast (te,ty) ->
- C.Cast (beta_reduce te, beta_reduce ty)
- | C.Prod (n,s,t) ->
- C.Prod (n, beta_reduce s, beta_reduce t)
- | C.Lambda (n,s,t) ->
- C.Lambda (n, beta_reduce s, beta_reduce t)
- | C.LetIn (n,s,t) ->
- C.LetIn (n, beta_reduce s, beta_reduce t)
- | C.Appl ((C.Lambda (name,s,t))::he::tl) ->
- let he' = S.subst he t in
- if tl = [] then
- beta_reduce he'
- else
- (match he' with
- C.Appl l -> beta_reduce (C.Appl (l@tl))
- | _ -> beta_reduce (C.Appl (he'::tl)))
- | C.Appl l ->
- C.Appl (List.map beta_reduce l)
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (i,t) -> i, beta_reduce t) exp_named_subst
- in
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri,i,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (i,t) -> i, beta_reduce t) exp_named_subst
- in
- C.MutInd (uri,i,exp_named_subst')
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (i,t) -> i, beta_reduce t) exp_named_subst
- in
- C.MutConstruct (uri,i,j,exp_named_subst')
- | C.MutCase (sp,i,outt,t,pl) ->
- C.MutCase (sp,i,beta_reduce outt,beta_reduce t,
- List.map beta_reduce pl)
- | C.Fix (i,fl) ->
- let fl' =
- List.map
- (function (name,i,ty,bo) ->
- name,i,beta_reduce ty,beta_reduce bo
- ) fl
- in
- C.Fix (i,fl')
- | C.CoFix (i,fl) ->
- let fl' =
- List.map
- (function (name,ty,bo) ->
- name,beta_reduce ty,beta_reduce bo
- ) fl
- in
- C.CoFix (i,fl')
-;;
-
-(* syntactic_equality up to the *)
-(* distinction between fake dependent products *)
-(* and non-dependent products, alfa-conversion *)
-(*CSC: must alfa-conversion be considered or not? *)
-let syntactic_equality t t' =
- let module C = Cic in
- let rec syntactic_equality t t' =
- if t = t' then true
- else
- match t, t' with
- C.Var (uri,exp_named_subst), C.Var (uri',exp_named_subst') ->
- UriManager.eq uri uri' &&
- syntactic_equality_exp_named_subst exp_named_subst exp_named_subst'
- | C.Cast (te,ty), C.Cast (te',ty') ->
- syntactic_equality te te' &&
- syntactic_equality ty ty'
- | C.Prod (_,s,t), C.Prod (_,s',t') ->
- syntactic_equality s s' &&
- syntactic_equality t t'
- | C.Lambda (_,s,t), C.Lambda (_,s',t') ->
- syntactic_equality s s' &&
- syntactic_equality t t'
- | C.LetIn (_,s,t), C.LetIn(_,s',t') ->
- syntactic_equality s s' &&
- syntactic_equality t t'
- | C.Appl l, C.Appl l' ->
- List.fold_left2 (fun b t1 t2 -> b && syntactic_equality t1 t2) true l l'
- | C.Const (uri,exp_named_subst), C.Const (uri',exp_named_subst') ->
- UriManager.eq uri uri' &&
- syntactic_equality_exp_named_subst exp_named_subst exp_named_subst'
- | C.MutInd (uri,i,exp_named_subst), C.MutInd (uri',i',exp_named_subst') ->
- UriManager.eq uri uri' && i = i' &&
- syntactic_equality_exp_named_subst exp_named_subst exp_named_subst'
- | C.MutConstruct (uri,i,j,exp_named_subst),
- C.MutConstruct (uri',i',j',exp_named_subst') ->
- UriManager.eq uri uri' && i = i' && j = j' &&
- syntactic_equality_exp_named_subst exp_named_subst exp_named_subst'
- | C.MutCase (sp,i,outt,t,pl), C.MutCase (sp',i',outt',t',pl') ->
- UriManager.eq sp sp' && i = i' &&
- syntactic_equality outt outt' &&
- syntactic_equality t t' &&
- List.fold_left2
- (fun b t1 t2 -> b && syntactic_equality t1 t2) true pl pl'
- | C.Fix (i,fl), C.Fix (i',fl') ->
- i = i' &&
- List.fold_left2
- (fun b (_,i,ty,bo) (_,i',ty',bo') ->
- b && i = i' &&
- syntactic_equality ty ty' &&
- syntactic_equality bo bo') true fl fl'
- | C.CoFix (i,fl), C.CoFix (i',fl') ->
- i = i' &&
- List.fold_left2
- (fun b (_,ty,bo) (_,ty',bo') ->
- b &&
- syntactic_equality ty ty' &&
- syntactic_equality bo bo') true fl fl'
- | _, _ -> false (* we already know that t != t' *)
- and syntactic_equality_exp_named_subst exp_named_subst1 exp_named_subst2 =
- List.fold_left2
- (fun b (_,t1) (_,t2) -> b && syntactic_equality t1 t2) true
- exp_named_subst1 exp_named_subst2
- in
- try
- syntactic_equality t t'
- with
- _ -> false
-;;
-
-let xxx_syntactic_equality t t' =
- let t1 = Sys.time () in
- let res = syntactic_equality t t' in
- let t2 = Sys.time () in
- syntactic_equality_add_time := !syntactic_equality_add_time +. t2 -. t1 ;
- res
-;;
-
-
-let rec split l n =
- match (l,n) with
- (l,0) -> ([], l)
- | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2)
- | (_,_) -> raise ListTooShort
-;;
-
-let type_of_constant uri =
- let module C = Cic in
- let module R = CicReduction in
- let module U = UriManager in
- let cobj =
- match CicEnvironment.is_type_checked CicUniv.empty_ugraph uri with
- CicEnvironment.CheckedObj (cobj,_) -> cobj
- | CicEnvironment.UncheckedObj uobj ->
- raise (NotWellTyped "Reference to an unchecked constant")
- in
- match cobj with
- C.Constant (_,_,ty,_,_) -> ty
- | C.CurrentProof (_,_,_,ty,_,_) -> ty
- | _ -> raise (WrongUriToConstant (U.string_of_uri uri))
-;;
-
-let type_of_variable uri =
- let module C = Cic in
- let module R = CicReduction in
- let module U = UriManager in
- match CicEnvironment.is_type_checked CicUniv.empty_ugraph uri with
- CicEnvironment.CheckedObj ((C.Variable (_,_,ty,_,_)),_) -> ty
- | CicEnvironment.UncheckedObj (C.Variable _) ->
- raise (NotWellTyped "Reference to an unchecked variable")
- | _ -> raise (WrongUriToVariable (UriManager.string_of_uri uri))
-;;
-
-let type_of_mutual_inductive_defs uri i =
- let module C = Cic in
- let module R = CicReduction in
- let module U = UriManager in
- let cobj =
- match CicEnvironment.is_type_checked CicUniv.empty_ugraph uri with
- CicEnvironment.CheckedObj (cobj,_) -> cobj
- | CicEnvironment.UncheckedObj uobj ->
- raise (NotWellTyped "Reference to an unchecked inductive type")
- in
- match cobj with
- C.InductiveDefinition (dl,_,_,_) ->
- let (_,_,arity,_) = List.nth dl i in
- arity
- | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
-;;
-
-let type_of_mutual_inductive_constr uri i j =
- let module C = Cic in
- let module R = CicReduction in
- let module U = UriManager in
- let cobj =
- match CicEnvironment.is_type_checked CicUniv.empty_ugraph uri with
- CicEnvironment.CheckedObj (cobj,_) -> cobj
- | CicEnvironment.UncheckedObj uobj ->
- raise (NotWellTyped "Reference to an unchecked constructor")
- in
- match cobj with
- C.InductiveDefinition (dl,_,_,_) ->
- let (_,_,_,cl) = List.nth dl i in
- let (_,ty) = List.nth cl (j-1) in
- ty
- | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
-;;
-
-module CicHash =
- struct
- module Tmp =
- Hashtbl.Make
- (struct
- type t = Cic.term
- let equal = (==)
- let hash = Hashtbl.hash
- end)
- include Tmp
- let empty () = Tmp.create 1
- end
-;;
-
-(* type_of_aux' is just another name (with a different scope) for type_of_aux *)
-let rec type_of_aux' subterms_to_types metasenv context t expectedty =
- (* Coscoy's double type-inference algorithm *)
- (* It computes the inner-types of every subterm of [t], *)
- (* even when they are not needed to compute the types *)
- (* of other terms. *)
- let rec type_of_aux context t expectedty =
- let module C = Cic in
- let module R = CicReduction in
- let module S = CicSubstitution in
- let module U = UriManager in
- let synthesized =
- match t with
- C.Rel n ->
- (try
- match List.nth context (n - 1) with
- Some (_,C.Decl t) -> S.lift n t
- | Some (_,C.Def (_,Some ty)) -> S.lift n ty
- | Some (_,C.Def (bo,None)) ->
- type_of_aux context (S.lift n bo) expectedty
- | None -> raise RelToHiddenHypothesis
- with
- _ -> raise (NotWellTyped "Not a close term")
- )
- | C.Var (uri,exp_named_subst) ->
- visit_exp_named_subst context uri exp_named_subst ;
- CicSubstitution.subst_vars exp_named_subst (type_of_variable uri)
- | C.Meta (n,l) ->
- (* Let's visit all the subterms that will not be visited later *)
- let (_,canonical_context,_) = CicUtil.lookup_meta n metasenv in
- let lifted_canonical_context =
- let rec aux i =
- function
- [] -> []
- | (Some (n,C.Decl t))::tl ->
- (Some (n,C.Decl (S.subst_meta l (S.lift i t))))::(aux (i+1) tl)
- | (Some (n,C.Def (t,None)))::tl ->
- (Some (n,C.Def ((S.subst_meta l (S.lift i t)),None)))::
- (aux (i+1) tl)
- | None::tl -> None::(aux (i+1) tl)
- | (Some (_,C.Def (_,Some _)))::_ -> assert false
- in
- aux 1 canonical_context
- in
- let _ =
- List.iter2
- (fun t ct ->
- match t,ct with
- _,None -> ()
- | Some t,Some (_,C.Def (ct,_)) ->
- let expected_type =
- R.whd context
- (xxx_type_of_aux' metasenv context ct)
- in
- (* Maybe I am a bit too paranoid, because *)
- (* if the term is well-typed than t and ct *)
- (* are convertible. Nevertheless, I compute *)
- (* the expected type. *)
- ignore (type_of_aux context t (Some expected_type))
- | Some t,Some (_,C.Decl ct) ->
- ignore (type_of_aux context t (Some ct))
- | _,_ -> assert false (* the term is not well typed!!! *)
- ) l lifted_canonical_context
- in
- let (_,canonical_context,ty) = CicUtil.lookup_meta n metasenv in
- (* Checks suppressed *)
- CicSubstitution.subst_meta l ty
- | C.Sort (C.Type t) -> (* TASSI: CONSTRAINT *)
- C.Sort (C.Type (CicUniv.fresh()))
- | C.Sort _ -> C.Sort (C.Type (CicUniv.fresh())) (* TASSI: CONSTRAINT *)
- | C.Implicit _ -> raise (Impossible 21)
- | C.Cast (te,ty) ->
- (* Let's visit all the subterms that will not be visited later *)
- let _ = type_of_aux context te (Some (beta_reduce ty)) in
- let _ = type_of_aux context ty None in
- (* Checks suppressed *)
- ty
- | C.Prod (name,s,t) ->
- let sort1 = type_of_aux context s None
- and sort2 = type_of_aux ((Some (name,(C.Decl s)))::context) t None in
- sort_of_prod context (name,s) (sort1,sort2)
- | C.Lambda (n,s,t) ->
- (* Let's visit all the subterms that will not be visited later *)
- let _ = type_of_aux context s None in
- let expected_target_type =
- match expectedty with
- None -> None
- | Some expectedty' ->
- let ty =
- match R.whd context expectedty' with
- C.Prod (_,_,expected_target_type) ->
- beta_reduce expected_target_type
- | _ -> assert false
- in
- Some ty
- in
- let type2 =
- type_of_aux ((Some (n,(C.Decl s)))::context) t expected_target_type
- in
- (* Checks suppressed *)
- C.Prod (n,s,type2)
- | C.LetIn (n,s,t) ->
-(*CSC: What are the right expected types for the source and *)
-(*CSC: target of a LetIn? None used. *)
- (* Let's visit all the subterms that will not be visited later *)
- let ty = type_of_aux context s None in
- let t_typ =
- (* Checks suppressed *)
- type_of_aux ((Some (n,(C.Def (s,Some ty))))::context) t None
- in (* CicSubstitution.subst s t_typ *)
- if does_not_occur 1 t_typ then
- (* since [Rel 1] does not occur in typ, substituting any term *)
- (* in place of [Rel 1] is equivalent to delifting once *)
- CicSubstitution.subst (C.Implicit None) t_typ
- else
- C.LetIn (n,s,t_typ)
- | C.Appl (he::tl) when List.length tl > 0 ->
- (*
- let expected_hetype =
- (* Inefficient, the head is computed twice. But I know *)
- (* of no other solution. *)
- (beta_reduce
- (R.whd context (xxx_type_of_aux' metasenv context he)))
- in
- let hetype = type_of_aux context he (Some expected_hetype) in
- let tlbody_and_type =
- let rec aux =
- function
- _,[] -> []
- | C.Prod (n,s,t),he::tl ->
- (he, type_of_aux context he (Some (beta_reduce s)))::
- (aux (R.whd context (S.subst he t), tl))
- | _ -> assert false
- in
- aux (expected_hetype, tl) *)
- let hetype = R.whd context (type_of_aux context he None) in
- let tlbody_and_type =
- let rec aux =
- function
- _,[] -> []
- | C.Prod (n,s,t),he::tl ->
- (he, type_of_aux context he (Some (beta_reduce s)))::
- (aux (R.whd context (S.subst he t), tl))
- | _ -> assert false
- in
- aux (hetype, tl)
- in
- eat_prods context hetype tlbody_and_type
- | C.Appl _ -> raise (NotWellTyped "Appl: no arguments")
- | C.Const (uri,exp_named_subst) ->
- visit_exp_named_subst context uri exp_named_subst ;
- CicSubstitution.subst_vars exp_named_subst (type_of_constant uri)
- | C.MutInd (uri,i,exp_named_subst) ->
- visit_exp_named_subst context uri exp_named_subst ;
- CicSubstitution.subst_vars exp_named_subst
- (type_of_mutual_inductive_defs uri i)
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- visit_exp_named_subst context uri exp_named_subst ;
- CicSubstitution.subst_vars exp_named_subst
- (type_of_mutual_inductive_constr uri i j)
- | C.MutCase (uri,i,outtype,term,pl) ->
- let outsort = type_of_aux context outtype None in
- let (need_dummy, k) =
- let rec guess_args context t =
- match CicReduction.whd context t with
- C.Sort _ -> (true, 0)
- | C.Prod (name, s, t) ->
- let (b, n) = guess_args ((Some (name,(C.Decl s)))::context) t in
- if n = 0 then
- (* last prod before sort *)
- match CicReduction.whd context s with
- C.MutInd (uri',i',_) when U.eq uri' uri && i' = i ->
- (false, 1)
- | C.Appl ((C.MutInd (uri',i',_)) :: _)
- when U.eq uri' uri && i' = i -> (false, 1)
- | _ -> (true, 1)
- else
- (b, n + 1)
- | _ -> raise (NotWellTyped "MutCase: outtype ill-formed")
- in
- let (b, k) = guess_args context outsort in
- if not b then (b, k - 1) else (b, k)
- in
- let (parameters, arguments,exp_named_subst) =
- let type_of_term =
- xxx_type_of_aux' metasenv context term
- in
- match
- R.whd context (type_of_aux context term
- (Some (beta_reduce type_of_term)))
- with
- (*CSC manca il caso dei CAST *)
- C.MutInd (uri',i',exp_named_subst) ->
- (* Checks suppressed *)
- [],[],exp_named_subst
- | C.Appl (C.MutInd (uri',i',exp_named_subst) :: tl) ->
- let params,args =
- split tl (List.length tl - k)
- in params,args,exp_named_subst
- | _ ->
- raise (NotWellTyped "MutCase: the term is not an inductive one")
- in
- (* Checks suppressed *)
- (* Let's visit all the subterms that will not be visited later *)
- let (cl,parsno) =
- let obj,_ =
- try
- CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
- with Not_found -> assert false
- in
- match obj with
- C.InductiveDefinition (tl,_,parsno,_) ->
- let (_,_,_,cl) = List.nth tl i in (cl,parsno)
- | _ ->
- raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
- in
- let _ =
- List.fold_left
- (fun j (p,(_,c)) ->
- let cons =
- if parameters = [] then
- (C.MutConstruct (uri,i,j,exp_named_subst))
- else
- (C.Appl (C.MutConstruct (uri,i,j,exp_named_subst)::parameters))
- in
- let expectedtype =
- type_of_branch context parsno need_dummy outtype cons
- (xxx_type_of_aux' metasenv context cons)
- in
- ignore (type_of_aux context p
- (Some (beta_reduce expectedtype))) ;
- j+1
- ) 1 (List.combine pl cl)
- in
- if not need_dummy then
- C.Appl ((outtype::arguments)@[term])
- else if arguments = [] then
- outtype
- else
- C.Appl (outtype::arguments)
- | C.Fix (i,fl) ->
- (* Let's visit all the subterms that will not be visited later *)
- let context' =
- List.rev
- (List.map
- (fun (n,_,ty,_) ->
- let _ = type_of_aux context ty None in
- (Some (C.Name n,(C.Decl ty)))
- ) fl
- ) @
- context
- in
- let _ =
- List.iter
- (fun (_,_,ty,bo) ->
- let expectedty =
- beta_reduce (CicSubstitution.lift (List.length fl) ty)
- in
- ignore (type_of_aux context' bo (Some expectedty))
- ) fl
- in
- (* Checks suppressed *)
- let (_,_,ty,_) = List.nth fl i in
- ty
- | C.CoFix (i,fl) ->
- (* Let's visit all the subterms that will not be visited later *)
- let context' =
- List.rev
- (List.map
- (fun (n,ty,_) ->
- let _ = type_of_aux context ty None in
- (Some (C.Name n,(C.Decl ty)))
- ) fl
- ) @
- context
- in
- let _ =
- List.iter
- (fun (_,ty,bo) ->
- let expectedty =
- beta_reduce (CicSubstitution.lift (List.length fl) ty)
- in
- ignore (type_of_aux context' bo (Some expectedty))
- ) fl
- in
- (* Checks suppressed *)
- let (_,ty,_) = List.nth fl i in
- ty
- in
- let synthesized' = beta_reduce synthesized in
- let types,res =
- match expectedty with
- None ->
- (* No expected type *)
- {synthesized = synthesized' ; expected = None}, synthesized
- | Some ty when xxx_syntactic_equality synthesized' ty ->
- (* The expected type is synthactically equal to *)
- (* the synthesized type. Let's forget it. *)
- {synthesized = synthesized' ; expected = None}, synthesized
- | Some expectedty' ->
- {synthesized = synthesized' ; expected = Some expectedty'},
- expectedty'
- in
- assert (not (CicHash.mem subterms_to_types t));
- CicHash.add subterms_to_types t types ;
- res
-
- and visit_exp_named_subst context uri exp_named_subst =
- let uris_and_types =
- let obj,_ =
- try
- CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
- with Not_found -> assert false
- in
- let params = CicUtil.params_of_obj obj in
- List.map
- (function uri ->
- let obj,_ =
- try
- CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
- with Not_found -> assert false
- in
- match obj with
- Cic.Variable (_,None,ty,_,_) -> uri,ty
- | _ -> assert false (* the theorem is well-typed *)
- ) params
- in
- let rec check uris_and_types subst =
- match uris_and_types,subst with
- _,[] -> []
- | (uri,ty)::tytl,(uri',t)::substtl when uri = uri' ->
- ignore (type_of_aux context t (Some ty)) ;
- let tytl' =
- List.map
- (function uri,t' -> uri,(CicSubstitution.subst_vars [uri',t] t')) tytl
- in
- check tytl' substtl
- | _,_ -> assert false (* the theorem is well-typed *)
- in
- check uris_and_types exp_named_subst
-
- and sort_of_prod context (name,s) (t1, t2) =
- let module C = Cic in
- let t1' = CicReduction.whd context t1 in
- let t2' = CicReduction.whd ((Some (name,C.Decl s))::context) t2 in
- match (t1', t2') with
- (C.Sort _, C.Sort s2)
- when (s2 = C.Prop or s2 = C.Set or s2 = C.CProp) ->
- (* different from Coq manual!!! *)
- C.Sort s2
- | (C.Sort (C.Type t1), C.Sort (C.Type t2)) ->
- C.Sort (C.Type (CicUniv.fresh()))
- | (C.Sort _,C.Sort (C.Type t1)) ->
- (* TASSI: CONSRTAINTS: the same in cictypechecker,cicrefine *)
- C.Sort (C.Type t1) (* c'e' bisogno di un fresh? *)
- | (C.Meta _, C.Sort _) -> t2'
- | (C.Meta _, (C.Meta (_,_) as t))
- | (C.Sort _, (C.Meta (_,_) as t)) when CicUtil.is_closed t ->
- t2'
- | (_,_) ->
- raise
- (NotWellTyped
- ("Prod: sort1= " ^ CicPp.ppterm t1' ^ " ; sort2= " ^ CicPp.ppterm t2'))
-
- and eat_prods context hetype =
- (*CSC: siamo sicuri che le are_convertible non lavorino con termini non *)
- (*CSC: cucinati *)
- function
- [] -> hetype
- | (hete, hety)::tl ->
- (match (CicReduction.whd context hetype) with
- Cic.Prod (n,s,t) ->
- (* Checks suppressed *)
- eat_prods context (CicSubstitution.subst hete t) tl
- | _ -> raise (NotWellTyped "Appl: wrong Prod-type")
- )
-
-and type_of_branch context argsno need_dummy outtype term constype =
- let module C = Cic in
- let module R = CicReduction in
- match R.whd context constype with
- C.MutInd (_,_,_) ->
- if need_dummy then
- outtype
- else
- C.Appl [outtype ; term]
- | C.Appl (C.MutInd (_,_,_)::tl) ->
- let (_,arguments) = split tl argsno
- in
- if need_dummy && arguments = [] then
- outtype
- else
- C.Appl (outtype::arguments@(if need_dummy then [] else [term]))
- | C.Prod (name,so,de) ->
- let term' =
- match CicSubstitution.lift 1 term with
- C.Appl l -> C.Appl (l@[C.Rel 1])
- | t -> C.Appl [t ; C.Rel 1]
- in
- C.Prod (C.Anonymous,so,type_of_branch
- ((Some (name,(C.Decl so)))::context) argsno need_dummy
- (CicSubstitution.lift 1 outtype) term' de)
- | _ -> raise (Impossible 20)
-
- in
- type_of_aux context t expectedty
-;;
-
-let double_type_of metasenv context t expectedty =
- let subterms_to_types = CicHash.create 503 in
- ignore (type_of_aux' subterms_to_types metasenv context t expectedty) ;
- subterms_to_types
-;;
+++ /dev/null
-exception Impossible of int
-exception NotWellTyped of string
-exception WrongUriToConstant of string
-exception WrongUriToVariable of string
-exception WrongUriToMutualInductiveDefinitions of string
-exception ListTooShort
-exception RelToHiddenHypothesis
-
-val syntactic_equality_add_time: float ref
-val type_of_aux'_add_time: float ref
-val number_new_type_of_aux'_double_work: int ref
-val number_new_type_of_aux': int ref
-val number_new_type_of_aux'_prop: int ref
-
-type types = {synthesized : Cic.term ; expected : Cic.term option};;
-
-module CicHash :
- sig
- type 'a t
- val find : 'a t -> Cic.term -> 'a
- val empty: unit -> 'a t
- end
-;;
-
-val double_type_of :
- Cic.metasenv -> Cic.context -> Cic.term -> Cic.term option -> types CicHash.t
-
-(** Auxiliary functions **)
-
-(* does_not_occur n te *)
-(* returns [true] if [Rel n] does not occur in [te] *)
-val does_not_occur : int -> Cic.term -> bool
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception ReferenceToNonVariable;;
-
-let prerr_endline _ = ();;
-
-(*
-let rec fix_lambdas_wrt_type ty te =
- let module C = Cic in
- let module S = CicSubstitution in
-(* prerr_endline ("entering fix_lambdas: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *)
- match ty with
- C.Prod (_,_,ty') ->
- (match CicReduction.whd [] te with
- C.Lambda (n,s,te') ->
- C.Lambda (n,s,fix_lambdas_wrt_type ty' te')
- | t ->
- let rec get_sources =
- function
- C.Prod (_,s,ty) -> s::(get_sources ty)
- | _ -> [] in
- let sources = get_sources ty in
- let no_sources = List.length sources in
- let rec mk_rels n shift =
- if n = 0 then []
- else (C.Rel (n + shift))::(mk_rels (n - 1) shift) in
- let t' = S.lift no_sources t in
- let t2 =
- match t' with
- C.Appl l ->
- C.LetIn
- (C.Name "w",t',C.Appl ((C.Rel 1)::(mk_rels no_sources 1)))
- | _ ->
- C.Appl (t'::(mk_rels no_sources 0)) in
- List.fold_right
- (fun source t -> C.Lambda (C.Name "y",source,t))
- sources t2)
- | _ -> te
-;; *)
-
-let rec fix_lambdas_wrt_type ty te =
- let module C = Cic in
- let module S = CicSubstitution in
-(* prerr_endline ("entering fix_lambdas: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *)
- match ty,te with
- C.Prod (_,_,ty'), C.Lambda (n,s,te') ->
- C.Lambda (n,s,fix_lambdas_wrt_type ty' te')
- | C.Prod (_,s,ty'), t ->
- let rec get_sources =
- function
- C.Prod (_,s,ty) -> s::(get_sources ty)
- | _ -> [] in
- let sources = get_sources ty in
- let no_sources = List.length sources in
- let rec mk_rels n shift =
- if n = 0 then []
- else (C.Rel (n + shift))::(mk_rels (n - 1) shift) in
- let t' = S.lift no_sources t in
- let t2 =
- match t' with
- C.Appl l ->
- C.LetIn (C.Name "w",t',C.Appl ((C.Rel 1)::(mk_rels no_sources 1)))
- | _ -> C.Appl (t'::(mk_rels no_sources 0)) in
- List.fold_right
- (fun source t -> C.Lambda (C.Name "y",CicReduction.whd [] source,t)) sources t2
- | _, _ -> te
-;;
-
-(*
-let rec fix_lambdas_wrt_type ty te =
- let module C = Cic in
- let module S = CicSubstitution in
-(* prerr_endline ("entering fix_lambdas: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *)
- match ty,te with
- C.Prod (_,_,ty'), C.Lambda (n,s,te') ->
- C.Lambda (n,s,fix_lambdas_wrt_type ty' te')
- | C.Prod (_,s,ty'), ((C.Appl (C.Const _ ::_)) as t) ->
- (* const have a fixed arity *)
- (* prerr_endline ("******** fl - eta expansion 0: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *)
- let t' = S.lift 1 t in
- C.Lambda (C.Name "x",s,
- C.LetIn
- (C.Name "H", fix_lambdas_wrt_type ty' t',
- C.Appl [C.Rel 1;C.Rel 2]))
- | C.Prod (_,s,ty'), C.Appl l ->
- (* prerr_endline ("******** fl - eta expansion 1: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *)
- let l' = List.map (S.lift 1) l in
- C.Lambda (C.Name "x",s,
- fix_lambdas_wrt_type ty' (C.Appl (l'@[C.Rel 1])))
- | C.Prod (_,s,ty'), _ ->
- (* prerr_endline ("******** fl - eta expansion 2: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *)
- flush stderr ;
- let te' = S.lift 1 te in
- C.Lambda (C.Name "x",s,
- fix_lambdas_wrt_type ty' (C.Appl [te';C.Rel 1]))
- | _, _ -> te
-;;*)
-
-let fix_according_to_type ty hd tl =
- let module C = Cic in
- let module S = CicSubstitution in
- let rec count_prods =
- function
- C.Prod (_,_,t) -> 1 + (count_prods t)
- | _ -> 0 in
- let expected_arity = count_prods ty in
- let rec aux n ty tl res =
- if n = 0 then
- (match tl with
- [] ->
- (match res with
- [] -> assert false
- | [res] -> res
- | _ -> C.Appl res)
- | _ ->
- match res with
- [] -> assert false
- | [a] -> C.Appl (a::tl)
- | _ ->
- (* prerr_endline ("******* too many args: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm (C.Appl res)); *)
- C.LetIn
- (C.Name "H",
- C.Appl res, C.Appl (C.Rel 1::(List.map (S.lift 1) tl))))
- else
- let name,source,target =
- (match ty with
- C.Prod (C.Name _ as n,s,t) -> n,s,t
- | C.Prod (C.Anonymous, s,t) -> C.Name "z",s,t
- | _ -> (* prods number may only increase for substitution *)
- assert false) in
- match tl with
- [] ->
- (* prerr_endline ("******* too few args: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm (C.Appl res)); *)
- let res' = List.map (S.lift 1) res in
- C.Lambda
- (name, source, aux (n-1) target [] (res'@[C.Rel 1]))
- | hd::tl' ->
- let hd' = fix_lambdas_wrt_type source hd in
- (* (prerr_endline ("++++++prima :" ^(CicPp.ppterm hd));
- prerr_endline ("++++++dopo :" ^(CicPp.ppterm hd'))); *)
- aux (n-1) (S.subst hd' target) tl' (res@[hd']) in
- aux expected_arity ty tl [hd]
-;;
-
-let eta_fix metasenv context t =
- let rec eta_fix' context t =
- (* prerr_endline ("entering aux with: term=" ^ CicPp.ppterm t);
- flush stderr ; *)
- let module C = Cic in
- let module S = CicSubstitution in
- match t with
- C.Rel n -> C.Rel n
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' = fix_exp_named_subst context exp_named_subst in
- C.Var (uri,exp_named_subst')
- | C.Meta (n,l) ->
- let (_,canonical_context,_) = CicUtil.lookup_meta n metasenv in
- let l' =
- List.map2
- (fun ct t ->
- match (ct, t) with
- None, _ -> None
- | _, Some t -> Some (eta_fix' context t)
- | Some _, None -> assert false (* due to typing rules *))
- canonical_context l
- in
- C.Meta (n,l')
- | C.Sort s -> C.Sort s
- | C.Implicit _ as t -> t
- | C.Cast (v,t) -> C.Cast (eta_fix' context v, eta_fix' context t)
- | C.Prod (n,s,t) ->
- C.Prod
- (n, eta_fix' context s, eta_fix' ((Some (n,(C.Decl s)))::context) t)
- | C.Lambda (n,s,t) ->
- C.Lambda
- (n, eta_fix' context s, eta_fix' ((Some (n,(C.Decl s)))::context) t)
- | C.LetIn (n,s,t) ->
- C.LetIn
- (n,eta_fix' context s,eta_fix' ((Some (n,(C.Def (s,None))))::context) t)
- | C.Appl l as appl ->
- let l' = List.map (eta_fix' context) l
- in
- (match l' with
- [] -> assert false
- | he::tl ->
- let ty,_ =
- CicTypeChecker.type_of_aux' metasenv context he
- CicUniv.empty_ugraph
- in
- fix_according_to_type ty he tl
-(*
- C.Const(uri,exp_named_subst)::l'' ->
- let constant_type =
- (match CicEnvironment.get_obj uri with
- C.Constant (_,_,ty,_) -> ty
- | C.Variable _ -> raise ReferenceToVariable
- | C.CurrentProof (_,_,_,_,params) -> raise ReferenceToCurrentProof
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- ) in
- fix_according_to_type
- constant_type (C.Const(uri,exp_named_subst)) l''
- | _ -> C.Appl l' *))
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' = fix_exp_named_subst context exp_named_subst in
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri,tyno,exp_named_subst) ->
- let exp_named_subst' = fix_exp_named_subst context exp_named_subst in
- C.MutInd (uri, tyno, exp_named_subst')
- | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
- let exp_named_subst' = fix_exp_named_subst context exp_named_subst in
- C.MutConstruct (uri, tyno, consno, exp_named_subst')
- | C.MutCase (uri, tyno, outty, term, patterns) as prima ->
- let outty' = eta_fix' context outty in
- let term' = eta_fix' context term in
- let patterns' = List.map (eta_fix' context) patterns in
- let inductive_types,noparams =
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- (match o with
- Cic.Constant _ -> assert false
- | Cic.Variable _ -> assert false
- | Cic.CurrentProof _ -> assert false
- | Cic.InductiveDefinition (l,_,n,_) -> l,n
- ) in
- let (_,_,_,constructors) = List.nth inductive_types tyno in
- let constructor_types =
- let rec clean_up t =
- function
- [] -> t
- | a::tl ->
- (match t with
- Cic.Prod (_,_,t') -> clean_up (S.subst a t') tl
- | _ -> assert false) in
- if noparams = 0 then
- List.map (fun (_,t) -> t) constructors
- else
- let term_type,_ =
- CicTypeChecker.type_of_aux' metasenv context term
- CicUniv.empty_ugraph
- in
- (match term_type with
- C.Appl (hd::params) ->
- let rec first_n n l =
- if n = 0 then []
- else
- (match l with
- a::tl -> a::(first_n (n-1) tl)
- | _ -> assert false) in
- List.map
- (fun (_,t) ->
- clean_up t (first_n noparams params)) constructors
- | _ -> prerr_endline ("QUA"); assert false) in
- let patterns2 =
- List.map2 fix_lambdas_wrt_type
- constructor_types patterns in
- C.MutCase (uri, tyno, outty',term',patterns2)
- | C.Fix (funno, funs) ->
- let fun_types =
- List.map (fun (n,_,ty,_) -> Some (C.Name n,(Cic.Decl ty))) funs in
- C.Fix (funno,
- List.map
- (fun (name, no, ty, bo) ->
- (name, no, eta_fix' context ty, eta_fix' (fun_types@context) bo))
- funs)
- | C.CoFix (funno, funs) ->
- let fun_types =
- List.map (fun (n,ty,_) -> Some (C.Name n,(Cic.Decl ty))) funs in
- C.CoFix (funno,
- List.map
- (fun (name, ty, bo) ->
- (name, eta_fix' context ty, eta_fix' (fun_types@context) bo)) funs)
- and fix_exp_named_subst context exp_named_subst =
- List.rev
- (List.fold_left
- (fun newsubst (uri,t) ->
- let t' = eta_fix' context t in
- let ty =
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- Cic.Variable (_,_,ty,_,_) ->
- CicSubstitution.subst_vars newsubst ty
- | _ -> raise ReferenceToNonVariable
- in
- let t'' = fix_according_to_type ty t' [] in
- (uri,t'')::newsubst
- ) [] exp_named_subst)
- in
- eta_fix' context t
-;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val eta_fix : Cic.metasenv -> Cic.context -> Cic.term -> Cic.term
-
-
+++ /dev/null
-*.cm[iaox] *.cmxa
+++ /dev/null
-cic2Xml.cmo: cic2Xml.cmi
-cic2Xml.cmx: cic2Xml.cmi
-content2pres.cmo: content2pres.cmi
-content2pres.cmx: content2pres.cmi
-sequent2pres.cmo: sequent2pres.cmi
-sequent2pres.cmx: sequent2pres.cmi
-domMisc.cmo: domMisc.cmi
-domMisc.cmx: domMisc.cmi
-xml2Gdome.cmo: xml2Gdome.cmi
-xml2Gdome.cmx: xml2Gdome.cmi
-applyTransformation.cmo: xml2Gdome.cmi sequent2pres.cmi domMisc.cmi \
- content2pres.cmi applyTransformation.cmi
-applyTransformation.cmx: xml2Gdome.cmx sequent2pres.cmx domMisc.cmx \
- content2pres.cmx applyTransformation.cmi
+++ /dev/null
-PACKAGE = cic_transformations
-PREDICATES =
-
-# modules which have both a .ml and a .mli
-INTERFACE_FILES = \
- cic2Xml.mli \
- content2pres.mli \
- sequent2pres.mli \
- domMisc.mli \
- xml2Gdome.mli \
- applyTransformation.mli \
- $(NULL)
-IMPLEMENTATION_FILES = \
- $(INTERFACE_FILES:%.mli=%.ml)
-EXTRA_OBJECTS_TO_INSTALL =
-EXTRA_OBJECTS_TO_CLEAN =
-
-all:
-
-clean: extra_clean
-distclean: extra_clean
-extra_clean:
- rm -f make_table
-
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(***************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 21/11/2003 *)
-(* *)
-(* *)
-(***************************************************************************)
-
-let mpres_document pres_box =
- Xml.add_xml_declaration (CicNotationPres.print_box pres_box)
-
-let mml_of_cic_sequent metasenv sequent =
- let unsh_sequent,(asequent,ids_to_terms,
- ids_to_father_ids,ids_to_inner_sorts,ids_to_hypotheses)
- =
- Cic2acic.asequent_of_sequent metasenv sequent
- in
- let content_sequent = Cic2content.map_sequent asequent in
- let pres_sequent =
- (Sequent2pres.sequent2pres ~ids_to_inner_sorts content_sequent)
- in
- let xmlpres = mpres_document pres_sequent in
- (Xml2Gdome.document_of_xml DomMisc.domImpl xmlpres,
- unsh_sequent,
- (asequent,
- (ids_to_terms,ids_to_father_ids,ids_to_hypotheses,ids_to_inner_sorts)))
-
-let mml_of_cic_object obj =
- let (annobj, ids_to_terms, ids_to_father_ids, ids_to_inner_sorts,
- ids_to_inner_types, ids_to_conjectures, ids_to_hypotheses)
- =
- Cic2acic.acic_object_of_cic_object obj
- in
- let content =
- Cic2content.annobj2content ~ids_to_inner_sorts ~ids_to_inner_types annobj
- in
- let pres = Content2pres.content2pres ~ids_to_inner_sorts content in
- let xmlpres = mpres_document pres in
- let mathml = Xml2Gdome.document_of_xml DomMisc.domImpl xmlpres in
- (mathml,(annobj,
- (ids_to_terms, ids_to_father_ids, ids_to_conjectures, ids_to_hypotheses,
- ids_to_inner_sorts,ids_to_inner_types)))
-
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(***************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 21/11/2003 *)
-(* *)
-(* *)
-(***************************************************************************)
-
-val mml_of_cic_sequent:
- Cic.metasenv -> (* metasenv *)
- Cic.conjecture -> (* sequent *)
- Gdome.document * (* Math ML *)
- Cic.conjecture * (* unshared sequent *)
- (Cic.annconjecture * (* annsequent *)
- ((Cic.id, Cic.term) Hashtbl.t * (* id -> term *)
- (Cic.id, Cic.id option) Hashtbl.t * (* id -> father id *)
- (Cic.id, Cic.hypothesis) Hashtbl.t * (* id -> hypothesis *)
- (Cic.id, Cic2acic.sort_kind) Hashtbl.t)) (* ids_to_inner_sorts *)
-
-val mml_of_cic_object:
- Cic.obj -> (* object *)
- Gdome.document * (* Math ML *)
- (Cic.annobj * (* annobj *)
- ((Cic.id, Cic.term) Hashtbl.t * (* id -> term *)
- (Cic.id, Cic.id option) Hashtbl.t * (* id -> father id *)
- (Cic.id, Cic.conjecture) Hashtbl.t * (* id -> conjecture *)
- (Cic.id, Cic.hypothesis) Hashtbl.t * (* id -> hypothesis *)
- (Cic.id, Cic2acic.sort_kind) Hashtbl.t * (* ids_to_inner_sorts *)
- (Cic.id, Cic2acic.anntypes) Hashtbl.t)) (* ids_to_inner_types *)
-
+++ /dev/null
-(* Copyright (C) 2000-2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(*CSC codice cut & paste da cicPp e xmlcommand *)
-
-exception NotImplemented;;
-
-let dtdname ~ask_dtd_to_the_getter dtd =
- if ask_dtd_to_the_getter then
- Helm_registry.get "getter.url" ^ "getdtd?uri=" ^ dtd
- else
- "http://mowgli.cs.unibo.it/dtd/" ^ dtd
-;;
-
-let param_attribute_of_params params =
- String.concat " " (List.map UriManager.string_of_uri params)
-;;
-
-(*CSC ottimizzazione: al posto di curi cdepth (vedi codice) *)
-let print_term ?ids_to_inner_sorts =
- let find_sort name id =
- match ids_to_inner_sorts with
- None -> []
- | Some ids_to_inner_sorts ->
- [None,name,Cic2acic.string_of_sort (Hashtbl.find ids_to_inner_sorts id)]
- in
- let rec aux =
- let module C = Cic in
- let module X = Xml in
- let module U = UriManager in
- function
- C.ARel (id,idref,n,b) ->
- let sort = find_sort "sort" id in
- X.xml_empty "REL"
- (sort @
- [None,"value",(string_of_int n) ; None,"binder",b ; None,"id",id ;
- None,"idref",idref])
- | C.AVar (id,uri,exp_named_subst) ->
- let sort = find_sort "sort" id in
- aux_subst uri
- (X.xml_empty "VAR"
- (sort @ [None,"uri",U.string_of_uri uri;None,"id",id]))
- exp_named_subst
- | C.AMeta (id,n,l) ->
- let sort = find_sort "sort" id in
- X.xml_nempty "META"
- (sort @ [None,"no",(string_of_int n) ; None,"id",id])
- (List.fold_left
- (fun i t ->
- match t with
- Some t' ->
- [< i ; X.xml_nempty "substitution" [] (aux t') >]
- | None ->
- [< i ; X.xml_empty "substitution" [] >]
- ) [< >] l)
- | C.ASort (id,s) ->
- let string_of_sort s =
- Cic2acic.string_of_sort (Cic2acic.sort_of_sort s)
- in
- X.xml_empty "SORT" [None,"value",(string_of_sort s) ; None,"id",id]
- | C.AImplicit _ -> raise NotImplemented
- | C.AProd (last_id,_,_,_) as prods ->
- let rec eat_prods =
- function
- C.AProd (id,n,s,t) ->
- let prods,t' = eat_prods t in
- (id,n,s)::prods,t'
- | t -> [],t
- in
- let prods,t = eat_prods prods in
- let sort = find_sort "type" last_id in
- X.xml_nempty "PROD" sort
- [< List.fold_left
- (fun i (id,binder,s) ->
- let sort = find_sort "type" (Cic2acic.source_id_of_id id) in
- let attrs =
- sort @ ((None,"id",id)::
- match binder with
- C.Anonymous -> []
- | C.Name b -> [None,"binder",b])
- in
- [< i ; X.xml_nempty "decl" attrs (aux s) >]
- ) [< >] prods ;
- X.xml_nempty "target" [] (aux t)
- >]
- | C.ACast (id,v,t) ->
- let sort = find_sort "sort" id in
- X.xml_nempty "CAST" (sort @ [None,"id",id])
- [< X.xml_nempty "term" [] (aux v) ;
- X.xml_nempty "type" [] (aux t)
- >]
- | C.ALambda (last_id,_,_,_) as lambdas ->
- let rec eat_lambdas =
- function
- C.ALambda (id,n,s,t) ->
- let lambdas,t' = eat_lambdas t in
- (id,n,s)::lambdas,t'
- | t -> [],t
- in
- let lambdas,t = eat_lambdas lambdas in
- let sort = find_sort "sort" last_id in
- X.xml_nempty "LAMBDA" sort
- [< List.fold_left
- (fun i (id,binder,s) ->
- let sort = find_sort "type" (Cic2acic.source_id_of_id id) in
- let attrs =
- sort @ ((None,"id",id)::
- match binder with
- C.Anonymous -> []
- | C.Name b -> [None,"binder",b])
- in
- [< i ; X.xml_nempty "decl" attrs (aux s) >]
- ) [< >] lambdas ;
- X.xml_nempty "target" [] (aux t)
- >]
- | C.ALetIn (xid,C.Anonymous,s,t) ->
- assert false
- | C.ALetIn (last_id,C.Name _,_,_) as letins ->
- let rec eat_letins =
- function
- C.ALetIn (id,n,s,t) ->
- let letins,t' = eat_letins t in
- (id,n,s)::letins,t'
- | t -> [],t
- in
- let letins,t = eat_letins letins in
- let sort = find_sort "sort" last_id in
- X.xml_nempty "LETIN" sort
- [< List.fold_left
- (fun i (id,binder,s) ->
- let sort = find_sort "sort" id in
- let attrs =
- sort @ ((None,"id",id)::
- match binder with
- C.Anonymous -> []
- | C.Name b -> [None,"binder",b])
- in
- [< i ; X.xml_nempty "def" attrs (aux s) >]
- ) [< >] letins ;
- X.xml_nempty "target" [] (aux t)
- >]
- | C.AAppl (id,li) ->
- let sort = find_sort "sort" id in
- X.xml_nempty "APPLY" (sort @ [None,"id",id])
- [< (List.fold_right (fun x i -> [< (aux x) ; i >]) li [<>])
- >]
- | C.AConst (id,uri,exp_named_subst) ->
- let sort = find_sort "sort" id in
- aux_subst uri
- (X.xml_empty "CONST"
- (sort @ [None,"uri",(U.string_of_uri uri) ; None,"id",id])
- ) exp_named_subst
- | C.AMutInd (id,uri,i,exp_named_subst) ->
- aux_subst uri
- (X.xml_empty "MUTIND"
- [None, "uri", (U.string_of_uri uri) ;
- None, "noType", (string_of_int i) ;
- None, "id", id]
- ) exp_named_subst
- | C.AMutConstruct (id,uri,i,j,exp_named_subst) ->
- let sort = find_sort "sort" id in
- aux_subst uri
- (X.xml_empty "MUTCONSTRUCT"
- (sort @
- [None,"uri", (U.string_of_uri uri) ;
- None,"noType",(string_of_int i) ;
- None,"noConstr",(string_of_int j) ;
- None,"id",id])
- ) exp_named_subst
- | C.AMutCase (id,uri,typeno,ty,te,patterns) ->
- let sort = find_sort "sort" id in
- X.xml_nempty "MUTCASE"
- (sort @
- [None,"uriType",(U.string_of_uri uri) ;
- None,"noType", (string_of_int typeno) ;
- None,"id", id])
- [< X.xml_nempty "patternsType" [] [< (aux ty) >] ;
- X.xml_nempty "inductiveTerm" [] [< (aux te) >] ;
- List.fold_right
- (fun x i -> [< X.xml_nempty "pattern" [] [< aux x >] ; i>])
- patterns [<>]
- >]
- | C.AFix (id, no, funs) ->
- let sort = find_sort "sort" id in
- X.xml_nempty "FIX"
- (sort @ [None,"noFun", (string_of_int no) ; None,"id",id])
- [< List.fold_right
- (fun (id,fi,ai,ti,bi) i ->
- [< X.xml_nempty "FixFunction"
- [None,"id",id ; None,"name", fi ;
- None,"recIndex", (string_of_int ai)]
- [< X.xml_nempty "type" [] [< aux ti >] ;
- X.xml_nempty "body" [] [< aux bi >]
- >] ;
- i
- >]
- ) funs [<>]
- >]
- | C.ACoFix (id,no,funs) ->
- let sort = find_sort "sort" id in
- X.xml_nempty "COFIX"
- (sort @ [None,"noFun", (string_of_int no) ; None,"id",id])
- [< List.fold_right
- (fun (id,fi,ti,bi) i ->
- [< X.xml_nempty "CofixFunction" [None,"id",id ; None,"name", fi]
- [< X.xml_nempty "type" [] [< aux ti >] ;
- X.xml_nempty "body" [] [< aux bi >]
- >] ;
- i
- >]
- ) funs [<>]
- >]
- and aux_subst buri target subst =
-(*CSC: I have now no way to assign an ID to the explicit named substitution *)
- let id = None in
- if subst = [] then
- target
- else
- Xml.xml_nempty "instantiate"
- (match id with None -> [] | Some id -> [None,"id",id])
- [< target ;
- List.fold_left
- (fun i (uri,arg) ->
- let relUri =
- let buri_frags =
- Str.split (Str.regexp "/") (UriManager.string_of_uri buri) in
- let uri_frags =
- Str.split (Str.regexp "/") (UriManager.string_of_uri uri) in
- let rec find_relUri buri_frags uri_frags =
- match buri_frags,uri_frags with
- [_], _ -> String.concat "/" uri_frags
- | he1::tl1, he2::tl2 ->
- assert (he1 = he2) ;
- find_relUri tl1 tl2
- | _,_ -> assert false (* uri is not relative to buri *)
- in
- find_relUri buri_frags uri_frags
- in
- [< i ; Xml.xml_nempty "arg" [None,"relUri", relUri] (aux arg) >]
- ) [<>] subst
- >]
- in
- aux
-;;
-
-let xml_of_attrs attributes =
- let class_of = function
- | `Coercion -> Xml.xml_empty "class" [None,"value","coercion"]
- | `Elim s ->
- Xml.xml_nempty "class" [None,"value","elim"]
- [< Xml.xml_empty
- "SORT" [None,"value",
- (Cic2acic.string_of_sort (Cic2acic.sort_of_sort s)) ;
- None,"id","elimination_sort"] >]
- | `Record field_names ->
- Xml.xml_nempty "class" [None,"value","record"]
- (List.fold_right
- (fun name res ->
- [< Xml.xml_empty "field" [None,"name",name]; res >]
- ) field_names [<>])
- | `Projection -> Xml.xml_empty "class" [None,"value","projection"]
- in
- let flavour_of = function
- | `Definition -> Xml.xml_empty "flavour" [None, "value", "definition"]
- | `Fact -> Xml.xml_empty "flavour" [None, "value", "fact"]
- | `Lemma -> Xml.xml_empty "flavour" [None, "value", "lemma"]
- | `Remark -> Xml.xml_empty "flavour" [None, "value", "remark"]
- | `Theorem -> Xml.xml_empty "flavour" [None, "value", "theorem"]
- | `Variant -> Xml.xml_empty "flavour" [None, "value", "variant"]
- in
- let xml_attr_of = function
- | `Generated -> Xml.xml_empty "generated" []
- | `Class c -> class_of c
- | `Flavour f -> flavour_of f
- in
- let xml_attrs =
- List.fold_right
- (fun attr res -> [< xml_attr_of attr ; res >]) attributes [<>]
- in
- Xml.xml_nempty "attributes" [] xml_attrs
-
-let print_object uri ?ids_to_inner_sorts ~ask_dtd_to_the_getter obj =
- let module C = Cic in
- let module X = Xml in
- let module U = UriManager in
- let dtdname = dtdname ~ask_dtd_to_the_getter "cic.dtd" in
- match obj with
- C.ACurrentProof (id,idbody,n,conjectures,bo,ty,params,obj_attrs) ->
- let params' = param_attribute_of_params params in
- let xml_attrs = xml_of_attrs obj_attrs in
- let xml_for_current_proof_body =
-(*CSC: Should the CurrentProof also have the list of variables it depends on? *)
-(*CSC: I think so. Not implemented yet. *)
- X.xml_nempty "CurrentProof"
- [None,"of",UriManager.string_of_uri uri ; None,"id", id]
- [< xml_attrs;
- List.fold_left
- (fun i (cid,n,canonical_context,t) ->
- [< i ;
- X.xml_nempty "Conjecture"
- [None,"id",cid ; None,"no",(string_of_int n)]
- [< List.fold_left
- (fun i (hid,t) ->
- [< (match t with
- Some (n,C.ADecl t) ->
- X.xml_nempty "Decl"
- (match n with
- C.Name n' ->
- [None,"id",hid;None,"name",n']
- | C.Anonymous -> [None,"id",hid])
- (print_term ?ids_to_inner_sorts t)
- | Some (n,C.ADef t) ->
- X.xml_nempty "Def"
- (match n with
- C.Name n' ->
- [None,"id",hid;None,"name",n']
- | C.Anonymous -> [None,"id",hid])
- (print_term ?ids_to_inner_sorts t)
- | None -> X.xml_empty "Hidden" [None,"id",hid]
- ) ;
- i
- >]
- ) [< >] canonical_context ;
- X.xml_nempty "Goal" []
- (print_term ?ids_to_inner_sorts t)
- >]
- >])
- [< >] conjectures ;
- X.xml_nempty "body" [] (print_term ?ids_to_inner_sorts bo) >]
- in
- let xml_for_current_proof_type =
- X.xml_nempty "ConstantType"
- [None,"name",n ; None,"params",params' ; None,"id", id]
- (print_term ?ids_to_inner_sorts ty)
- in
- let xmlbo =
- [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- X.xml_cdata ("<!DOCTYPE CurrentProof SYSTEM \""^ dtdname ^ "\">\n");
- xml_for_current_proof_body
- >] in
- let xmlty =
- [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^ dtdname ^ "\">\n");
- xml_for_current_proof_type
- >]
- in
- xmlty, Some xmlbo
- | C.AConstant (id,idbody,n,bo,ty,params,obj_attrs) ->
- let params' = param_attribute_of_params params in
- let xml_attrs = xml_of_attrs obj_attrs in
- let xmlbo =
- match bo with
- None -> None
- | Some bo ->
- Some
- [< X.xml_cdata
- "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- X.xml_cdata
- ("<!DOCTYPE ConstantBody SYSTEM \"" ^ dtdname ^ "\">\n") ;
- X.xml_nempty "ConstantBody"
- [None,"for",UriManager.string_of_uri uri ;
- None,"params",params' ; None,"id", id]
- [< print_term ?ids_to_inner_sorts bo >]
- >]
- in
- let xmlty =
- [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^ dtdname ^ "\">\n");
- X.xml_nempty "ConstantType"
- [None,"name",n ; None,"params",params' ; None,"id", id]
- [< xml_attrs; print_term ?ids_to_inner_sorts ty >]
- >]
- in
- xmlty, xmlbo
- | C.AVariable (id,n,bo,ty,params,obj_attrs) ->
- let params' = param_attribute_of_params params in
- let xml_attrs = xml_of_attrs obj_attrs in
- let xmlbo =
- match bo with
- None -> [< >]
- | Some bo ->
- X.xml_nempty "body" [] [< print_term ?ids_to_inner_sorts bo >]
- in
- let aobj =
- [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- X.xml_cdata ("<!DOCTYPE Variable SYSTEM \"" ^ dtdname ^ "\">\n");
- X.xml_nempty "Variable"
- [None,"name",n ; None,"params",params' ; None,"id", id]
- [< xml_attrs; xmlbo;
- X.xml_nempty "type" [] (print_term ?ids_to_inner_sorts ty)
- >]
- >]
- in
- aobj, None
- | C.AInductiveDefinition (id,tys,params,nparams,obj_attrs) ->
- let params' = param_attribute_of_params params in
- let xml_attrs = xml_of_attrs obj_attrs in
- [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- X.xml_cdata
- ("<!DOCTYPE InductiveDefinition SYSTEM \"" ^ dtdname ^ "\">\n") ;
- X.xml_nempty "InductiveDefinition"
- [None,"noParams",string_of_int nparams ;
- None,"id",id ;
- None,"params",params']
- [< xml_attrs;
- (List.fold_left
- (fun i (id,typename,finite,arity,cons) ->
- [< i ;
- X.xml_nempty "InductiveType"
- [None,"id",id ; None,"name",typename ;
- None,"inductive",(string_of_bool finite)
- ]
- [< X.xml_nempty "arity" []
- (print_term ?ids_to_inner_sorts arity) ;
- (List.fold_left
- (fun i (name,lc) ->
- [< i ;
- X.xml_nempty "Constructor"
- [None,"name",name]
- (print_term ?ids_to_inner_sorts lc)
- >]) [<>] cons
- )
- >]
- >]
- ) [< >] tys
- )
- >]
- >], None
-;;
-
-let
- print_inner_types curi ~ids_to_inner_sorts ~ids_to_inner_types
- ~ask_dtd_to_the_getter
-=
- let module C2A = Cic2acic in
- let module X = Xml in
- let dtdname = dtdname ~ask_dtd_to_the_getter "cictypes.dtd" in
- [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- X.xml_cdata
- ("<!DOCTYPE InnerTypes SYSTEM \"" ^ dtdname ^ "\">\n") ;
- X.xml_nempty "InnerTypes" [None,"of",UriManager.string_of_uri curi]
- (Hashtbl.fold
- (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x ->
- [< x ;
- X.xml_nempty "TYPE" [None,"of",id]
- [< X.xml_nempty "synthesized" []
- [< print_term ~ids_to_inner_sorts synty >] ;
- match expty with
- None -> [<>]
- | Some expty' -> X.xml_nempty "expected" []
- [< print_term ~ids_to_inner_sorts expty' >]
- >]
- >]
- ) ids_to_inner_types [<>]
- )
- >]
-;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception NotImplemented
-
-val print_term :
- ?ids_to_inner_sorts: (string, Cic2acic.sort_kind) Hashtbl.t ->
- Cic.annterm ->
- Xml.token Stream.t
-
-val print_object :
- UriManager.uri ->
- ?ids_to_inner_sorts: (string, Cic2acic.sort_kind) Hashtbl.t ->
- ask_dtd_to_the_getter:bool ->
- Cic.annobj ->
- Xml.token Stream.t * Xml.token Stream.t option
-
-val print_inner_types :
- UriManager.uri ->
- ids_to_inner_sorts: (string, Cic2acic.sort_kind) Hashtbl.t ->
- ids_to_inner_types: (string, Cic2acic.anntypes) Hashtbl.t ->
- ask_dtd_to_the_getter:bool ->
- Xml.token Stream.t
-
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(***************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 17/06/2003 *)
-(* *)
-(***************************************************************************)
-
-module P = Mpresentation
-module B = Box
-module Con = Content
-
-let p_mtr a b = Mpresentation.Mtr(a,b)
-let p_mtd a b = Mpresentation.Mtd(a,b)
-let p_mtable a b = Mpresentation.Mtable(a,b)
-let p_mtext a b = Mpresentation.Mtext(a,b)
-let p_mi a b = Mpresentation.Mi(a,b)
-let p_mo a b = Mpresentation.Mo(a,b)
-let p_mrow a b = Mpresentation.Mrow(a,b)
-let p_mphantom a b = Mpresentation.Mphantom(a,b)
-
-let rec split n l =
- if n = 0 then [],l
- else let l1,l2 =
- split (n-1) (List.tl l) in
- (List.hd l)::l1,l2
-
-let get_xref = function
- | `Declaration d
- | `Hypothesis d -> d.Con.dec_id
- | `Proof p -> p.Con.proof_id
- | `Definition d -> d.Con.def_id
- | `Joint jo -> jo.Con.joint_id
-
-let hv_attrs =
- RenderingAttrs.spacing_attributes `BoxML
- @ RenderingAttrs.indent_attributes `BoxML
-
-let make_row items concl =
- B.b_hv hv_attrs (items @ [ concl ])
-(* match concl with
- B.V _ -> |+ big! +|
- B.b_v attrs [B.b_h [] items; B.b_indent concl]
- | _ -> |+ small +|
- B.b_h attrs (items@[B.b_space; concl]) *)
-
-let make_concl ?(attrs=[]) verb concl =
- B.b_hv (hv_attrs @ attrs) [ B.b_kw verb; concl ]
-(* match concl with
- B.V _ -> |+ big! +|
- B.b_v attrs [ B.b_kw verb; B.b_indent concl]
- | _ -> |+ small +|
- B.b_h attrs [ B.b_kw verb; B.b_space; concl ] *)
-
-let make_args_for_apply term2pres args =
- let make_arg_for_apply is_first arg row =
- let res =
- match arg with
- Con.Aux n -> assert false
- | Con.Premise prem ->
- let name =
- (match prem.Con.premise_binder with
- None -> "previous"
- | Some s -> s) in
- (B.b_object (P.Mi ([], name)))::row
- | Con.Lemma lemma ->
- let lemma_attrs = [
- Some "helm", "xref", lemma.Con.lemma_id;
- Some "xlink", "href", lemma.Con.lemma_uri ]
- in
- (B.b_object (P.Mi(lemma_attrs,lemma.Con.lemma_name)))::row
- | Con.Term t ->
- if is_first then
- (term2pres t)::row
- else (B.b_object (P.Mi([],"_")))::row
- | Con.ArgProof _
- | Con.ArgMethod _ ->
- (B.b_object (P.Mi([],"_")))::row
- in
- if is_first then res else B.skip::res
- in
- match args with
- hd::tl ->
- make_arg_for_apply true hd
- (List.fold_right (make_arg_for_apply false) tl [])
- | _ -> assert false
-
-let get_name = function
- | Some s -> s
- | None -> "_"
-
-let add_xref id = function
- | B.Text (attrs, t) -> B.Text (((Some "helm", "xref", id) :: attrs), t)
- | _ -> assert false (* TODO, add_xref is meaningful for all boxes *)
-
-let rec justification term2pres p =
- if ((p.Con.proof_conclude.Con.conclude_method = "Exact") or
- ((p.Con.proof_context = []) &
- (p.Con.proof_apply_context = []) &
- (p.Con.proof_conclude.Con.conclude_method = "Apply"))) then
- let pres_args =
- make_args_for_apply term2pres p.Con.proof_conclude.Con.conclude_args in
- B.H([],
- (B.b_kw "by")::B.b_space::
- B.Text([],"(")::pres_args@[B.Text([],")")])
- else proof2pres term2pres p
-
-and proof2pres term2pres p =
- let rec proof2pres p =
- let indent =
- let is_decl e =
- (match e with
- `Declaration _
- | `Hypothesis _ -> true
- | _ -> false) in
- ((List.filter is_decl p.Con.proof_context) != []) in
- let omit_conclusion = (not indent) && (p.Con.proof_context != []) in
- let concl =
- (match p.Con.proof_conclude.Con.conclude_conclusion with
- None -> None
- | Some t -> Some (term2pres t)) in
- let body =
- let presconclude =
- conclude2pres p.Con.proof_conclude indent omit_conclusion in
- let presacontext =
- acontext2pres p.Con.proof_apply_context presconclude indent in
- context2pres p.Con.proof_context presacontext in
- match p.Con.proof_name with
- None -> body
- | Some name ->
- let action =
- match concl with
- None -> body
- | Some ac ->
- B.Action
- ([None,"type","toggle"],
- [(make_concl ~attrs:[Some "helm", "xref", p.Con.proof_id]
- "proof of" ac); body])
- in
- B.V ([],
- [B.Text ([],"(" ^ name ^ ")");
- B.indent action])
-
- and context2pres c continuation =
- (* we generate a subtable for each context element, for selection
- purposes
- The table generated by the head-element does not have an xref;
- the whole context-proof is already selectable *)
- match c with
- [] -> continuation
- | hd::tl ->
- let continuation' =
- List.fold_right
- (fun ce continuation ->
- let xref = get_xref ce in
- B.V([Some "helm", "xref", xref ],
- [B.H([Some "helm", "xref", "ce_"^xref],
- [ce2pres_in_proof_context_element ce]);
- continuation])) tl continuation in
- let hd_xref= get_xref hd in
- B.V([],
- [B.H([Some "helm", "xref", "ce_"^hd_xref],
- [ce2pres_in_proof_context_element hd]);
- continuation'])
-
- and ce2pres_in_joint_context_element = function
- | `Inductive _ -> assert false (* TODO *)
- | (`Declaration _) as x -> ce2pres x
- | (`Hypothesis _) as x -> ce2pres x
- | (`Proof _) as x -> ce2pres x
- | (`Definition _) as x -> ce2pres x
-
- and ce2pres_in_proof_context_element = function
- | `Joint ho ->
- B.H ([],(List.map ce2pres_in_joint_context_element ho.Content.joint_defs))
- | (`Declaration _) as x -> ce2pres x
- | (`Hypothesis _) as x -> ce2pres x
- | (`Proof _) as x -> ce2pres x
- | (`Definition _) as x -> ce2pres x
-
- and ce2pres =
- function
- `Declaration d ->
- (match d.Con.dec_name with
- Some s ->
- let ty = term2pres d.Con.dec_type in
- B.H ([],
- [(B.b_kw "Assume");
- B.b_space;
- B.Object ([], P.Mi([],s));
- B.Text([],":");
- ty])
- | None ->
- prerr_endline "NO NAME!!"; assert false)
- | `Hypothesis h ->
- (match h.Con.dec_name with
- Some s ->
- let ty = term2pres h.Con.dec_type in
- B.H ([],
- [(B.b_kw "Suppose");
- B.b_space;
- B.Text([],"(");
- B.Object ([], P.Mi ([],s));
- B.Text([],")");
- B.b_space;
- ty])
- | None ->
- prerr_endline "NO NAME!!"; assert false)
- | `Proof p ->
- proof2pres p
- | `Definition d ->
- (match d.Con.def_name with
- Some s ->
- let term = term2pres d.Con.def_term in
- B.H ([],
- [ B.b_kw "Let"; B.b_space;
- B.Object ([], P.Mi([],s));
- B.Text([]," = ");
- term])
- | None ->
- prerr_endline "NO NAME!!"; assert false)
-
- and acontext2pres ac continuation indent =
- List.fold_right
- (fun p continuation ->
- let hd =
- if indent then
- B.indent (proof2pres p)
- else
- proof2pres p in
- B.V([Some "helm","xref",p.Con.proof_id],
- [B.H([Some "helm","xref","ace_"^p.Con.proof_id],[hd]);
- continuation])) ac continuation
-
- and conclude2pres conclude indent omit_conclusion =
- let tconclude_body =
- match conclude.Con.conclude_conclusion with
- Some t when
- not omit_conclusion or
- (* CSC: I ignore the omit_conclusion flag in this case. *)
- (* CSC: Is this the correct behaviour? In the stylesheets *)
- (* CSC: we simply generated nothing (i.e. the output type *)
- (* CSC: of the function should become an option. *)
- conclude.Con.conclude_method = "BU_Conversion" ->
- let concl = (term2pres t) in
- if conclude.Con.conclude_method = "BU_Conversion" then
- make_concl "that is equivalent to" concl
- else if conclude.Con.conclude_method = "FalseInd" then
- (* false ind is in charge to add the conclusion *)
- falseind conclude
- else
- let conclude_body = conclude_aux conclude in
- let ann_concl =
- if conclude.Con.conclude_method = "TD_Conversion" then
- make_concl "that is equivalent to" concl
- else make_concl "we conclude" concl in
- B.V ([], [conclude_body; ann_concl])
- | _ -> conclude_aux conclude in
- if indent then
- B.indent (B.H ([Some "helm", "xref", conclude.Con.conclude_id],
- [tconclude_body]))
- else
- B.H ([Some "helm", "xref", conclude.Con.conclude_id],[tconclude_body])
-
- and conclude_aux conclude =
- if conclude.Con.conclude_method = "TD_Conversion" then
- let expected =
- (match conclude.Con.conclude_conclusion with
- None -> B.Text([],"NO EXPECTED!!!")
- | Some c -> term2pres c) in
- let subproof =
- (match conclude.Con.conclude_args with
- [Con.ArgProof p] -> p
- | _ -> assert false) in
- let synth =
- (match subproof.Con.proof_conclude.Con.conclude_conclusion with
- None -> B.Text([],"NO SYNTH!!!")
- | Some c -> (term2pres c)) in
- B.V
- ([],
- [make_concl "we must prove" expected;
- make_concl "or equivalently" synth;
- proof2pres subproof])
- else if conclude.Con.conclude_method = "BU_Conversion" then
- assert false
- else if conclude.Con.conclude_method = "Exact" then
- let arg =
- (match conclude.Con.conclude_args with
- [Con.Term t] -> term2pres t
- | [Con.Premise p] ->
- (match p.Con.premise_binder with
- | None -> assert false; (* unnamed hypothesis ??? *)
- | Some s -> B.Text([],s))
- | err -> assert false) in
- (match conclude.Con.conclude_conclusion with
- None ->
- B.b_h [] [B.b_kw "Consider"; B.b_space; arg]
- | Some c -> let conclusion = term2pres c in
- make_row
- [arg; B.b_space; B.b_kw "proves"]
- conclusion
- )
- else if conclude.Con.conclude_method = "Intros+LetTac" then
- (match conclude.Con.conclude_args with
- [Con.ArgProof p] -> proof2pres p
- | _ -> assert false)
-(* OLD CODE
- let conclusion =
- (match conclude.Con.conclude_conclusion with
- None -> B.Text([],"NO Conclusion!!!")
- | Some c -> term2pres c) in
- (match conclude.Con.conclude_args with
- [Con.ArgProof p] ->
- B.V
- ([None,"align","baseline 1"; None,"equalrows","false";
- None,"columnalign","left"],
- [B.H([],[B.Object([],proof2pres p)]);
- B.H([],[B.Object([],
- (make_concl "we proved 1" conclusion))])]);
- | _ -> assert false)
-*)
- else if (conclude.Con.conclude_method = "Case") then
- case conclude
- else if (conclude.Con.conclude_method = "ByInduction") then
- byinduction conclude
- else if (conclude.Con.conclude_method = "Exists") then
- exists conclude
- else if (conclude.Con.conclude_method = "AndInd") then
- andind conclude
- else if (conclude.Con.conclude_method = "FalseInd") then
- falseind conclude
- else if (conclude.Con.conclude_method = "Rewrite") then
- let justif =
- (match (List.nth conclude.Con.conclude_args 6) with
- Con.ArgProof p -> justification term2pres p
- | _ -> assert false) in
- let term1 =
- (match List.nth conclude.Con.conclude_args 2 with
- Con.Term t -> term2pres t
- | _ -> assert false) in
- let term2 =
- (match List.nth conclude.Con.conclude_args 5 with
- Con.Term t -> term2pres t
- | _ -> assert false) in
- B.V ([],
- [B.H ([],[
- (B.b_kw "rewrite");
- B.b_space; term1;
- B.b_space; (B.b_kw "with");
- B.b_space; term2;
- B.indent justif])])
- else if conclude.Con.conclude_method = "Apply" then
- let pres_args =
- make_args_for_apply term2pres conclude.Con.conclude_args in
- B.H([],
- (B.b_kw "by")::
- B.b_space::
- B.Text([],"(")::pres_args@[B.Text([],")")])
- else
- B.V ([], [
- B.b_kw ("Apply method" ^ conclude.Con.conclude_method ^ " to");
- (B.indent (B.V ([], args2pres conclude.Con.conclude_args)))])
-
- and args2pres l = List.map arg2pres l
-
- and arg2pres =
- function
- Con.Aux n -> B.b_kw ("aux " ^ n)
- | Con.Premise prem -> B.b_kw "premise"
- | Con.Lemma lemma -> B.b_kw "lemma"
- | Con.Term t -> term2pres t
- | Con.ArgProof p -> proof2pres p
- | Con.ArgMethod s -> B.b_kw "method"
-
- and case conclude =
- let proof_conclusion =
- (match conclude.Con.conclude_conclusion with
- None -> B.b_kw "No conclusion???"
- | Some t -> term2pres t) in
- let arg,args_for_cases =
- (match conclude.Con.conclude_args with
- Con.Aux(_)::Con.Aux(_)::Con.Term(_)::arg::tl ->
- arg,tl
- | _ -> assert false) in
- let case_on =
- let case_arg =
- (match arg with
- Con.Aux n -> B.b_kw "an aux???"
- | Con.Premise prem ->
- (match prem.Con.premise_binder with
- None -> B.b_kw "the previous result"
- | Some n -> B.Object ([], P.Mi([],n)))
- | Con.Lemma lemma -> B.Object ([], P.Mi([],lemma.Con.lemma_name))
- | Con.Term t ->
- term2pres t
- | Con.ArgProof p -> B.b_kw "a proof???"
- | Con.ArgMethod s -> B.b_kw "a method???")
- in
- (make_concl "we proceed by cases on" case_arg) in
- let to_prove =
- (make_concl "to prove" proof_conclusion) in
- B.V ([], case_on::to_prove::(make_cases args_for_cases))
-
- and byinduction conclude =
- let proof_conclusion =
- (match conclude.Con.conclude_conclusion with
- None -> B.b_kw "No conclusion???"
- | Some t -> term2pres t) in
- let inductive_arg,args_for_cases =
- (match conclude.Con.conclude_args with
- Con.Aux(n)::_::tl ->
- let l1,l2 = split (int_of_string n) tl in
- let last_pos = (List.length l2)-1 in
- List.nth l2 last_pos,l1
- | _ -> assert false) in
- let induction_on =
- let arg =
- (match inductive_arg with
- Con.Aux n -> B.b_kw "an aux???"
- | Con.Premise prem ->
- (match prem.Con.premise_binder with
- None -> B.b_kw "the previous result"
- | Some n -> B.Object ([], P.Mi([],n)))
- | Con.Lemma lemma -> B.Object ([], P.Mi([],lemma.Con.lemma_name))
- | Con.Term t ->
- term2pres t
- | Con.ArgProof p -> B.b_kw "a proof???"
- | Con.ArgMethod s -> B.b_kw "a method???") in
- (make_concl "we proceed by induction on" arg) in
- let to_prove =
- (make_concl "to prove" proof_conclusion) in
- B.V ([], induction_on::to_prove:: (make_cases args_for_cases))
-
- and make_cases l = List.map make_case l
-
- and make_case =
- function
- Con.ArgProof p ->
- let name =
- (match p.Con.proof_name with
- None -> B.b_kw "no name for case!!"
- | Some n -> B.Object ([], P.Mi([],n))) in
- let indhyps,args =
- List.partition
- (function
- `Hypothesis h -> h.Con.dec_inductive
- | _ -> false) p.Con.proof_context in
- let pattern_aux =
- List.fold_right
- (fun e p ->
- let dec =
- (match e with
- `Declaration h
- | `Hypothesis h ->
- let name =
- (match h.Con.dec_name with
- None -> "NO NAME???"
- | Some n ->n) in
- [B.b_space;
- B.Object ([], P.Mi ([],name));
- B.Text([],":");
- (term2pres h.Con.dec_type)]
- | _ -> [B.Text ([],"???")]) in
- dec@p) args [] in
- let pattern =
- B.H ([],
- (B.b_kw "Case"::B.b_space::name::pattern_aux)@
- [B.b_space;
- B.Text([], Utf8Macro.unicode_of_tex "\\Rightarrow")]) in
- let subconcl =
- (match p.Con.proof_conclude.Con.conclude_conclusion with
- None -> B.b_kw "No conclusion!!!"
- | Some t -> term2pres t) in
- let asubconcl = B.indent (make_concl "the thesis becomes" subconcl) in
- let induction_hypothesis =
- (match indhyps with
- [] -> []
- | _ ->
- let text = B.indent (B.b_kw "by induction hypothesis we know") in
- let make_hyp =
- function
- `Hypothesis h ->
- let name =
- (match h.Con.dec_name with
- None -> "no name"
- | Some s -> s) in
- B.indent (B.H ([],
- [B.Text([],"(");
- B.Object ([], P.Mi ([],name));
- B.Text([],")");
- B.b_space;
- term2pres h.Con.dec_type]))
- | _ -> assert false in
- let hyps = List.map make_hyp indhyps in
- text::hyps) in
- (* let acontext =
- acontext2pres_old p.Con.proof_apply_context true in *)
- let body = conclude2pres p.Con.proof_conclude true false in
- let presacontext =
- let acontext_id =
- match p.Con.proof_apply_context with
- [] -> p.Con.proof_conclude.Con.conclude_id
- | {Con.proof_id = id}::_ -> id
- in
- B.Action([None,"type","toggle"],
- [ B.indent (add_xref acontext_id (B.b_kw "Proof"));
- acontext2pres p.Con.proof_apply_context body true]) in
- B.V ([], pattern::asubconcl::induction_hypothesis@[presacontext])
- | _ -> assert false
-
- and falseind conclude =
- let proof_conclusion =
- (match conclude.Con.conclude_conclusion with
- None -> B.b_kw "No conclusion???"
- | Some t -> term2pres t) in
- let case_arg =
- (match conclude.Con.conclude_args with
- [Con.Aux(n);_;case_arg] -> case_arg
- | _ -> assert false;
- (*
- List.map (ContentPp.parg 0) conclude.Con.conclude_args;
- assert false *)) in
- let arg =
- (match case_arg with
- Con.Aux n -> assert false
- | Con.Premise prem ->
- (match prem.Con.premise_binder with
- None -> [B.b_kw "Contradiction, hence"]
- | Some n ->
- [ B.Object ([],P.Mi([],n)); B.skip;
- B.b_kw "is contradictory, hence"])
- | Con.Lemma lemma ->
- [ B.Object ([], P.Mi([],lemma.Con.lemma_name)); B.skip;
- B.b_kw "is contradictory, hence" ]
- | _ -> assert false) in
- (* let body = proof2pres {proof with Con.proof_context = tl} in *)
- make_row arg proof_conclusion
-
- and andind conclude =
- let proof_conclusion =
- (match conclude.Con.conclude_conclusion with
- None -> B.b_kw "No conclusion???"
- | Some t -> term2pres t) in
- let proof,case_arg =
- (match conclude.Con.conclude_args with
- [Con.Aux(n);_;Con.ArgProof proof;case_arg] -> proof,case_arg
- | _ -> assert false;
- (*
- List.map (ContentPp.parg 0) conclude.Con.conclude_args;
- assert false *)) in
- let arg =
- (match case_arg with
- Con.Aux n -> assert false
- | Con.Premise prem ->
- (match prem.Con.premise_binder with
- None -> []
- | Some n -> [(B.b_kw "by"); B.b_space; B.Object([], P.Mi([],n))])
- | Con.Lemma lemma ->
- [(B.b_kw "by");B.skip;
- B.Object([], P.Mi([],lemma.Con.lemma_name))]
- | _ -> assert false) in
- match proof.Con.proof_context with
- `Hypothesis hyp1::`Hypothesis hyp2::tl ->
- let get_name hyp =
- (match hyp.Con.dec_name with
- None -> "_"
- | Some s -> s) in
- let preshyp1 =
- B.H ([],
- [B.Text([],"(");
- B.Object ([], P.Mi([],get_name hyp1));
- B.Text([],")");
- B.skip;
- term2pres hyp1.Con.dec_type]) in
- let preshyp2 =
- B.H ([],
- [B.Text([],"(");
- B.Object ([], P.Mi([],get_name hyp2));
- B.Text([],")");
- B.skip;
- term2pres hyp2.Con.dec_type]) in
- (* let body = proof2pres {proof with Con.proof_context = tl} in *)
- let body = conclude2pres proof.Con.proof_conclude false true in
- let presacontext =
- acontext2pres proof.Con.proof_apply_context body false in
- B.V
- ([],
- [B.H ([],arg@[B.skip; B.b_kw "we have"]);
- preshyp1;
- B.b_kw "and";
- preshyp2;
- presacontext]);
- | _ -> assert false
-
- and exists conclude =
- let proof_conclusion =
- (match conclude.Con.conclude_conclusion with
- None -> B.b_kw "No conclusion???"
- | Some t -> term2pres t) in
- let proof =
- (match conclude.Con.conclude_args with
- [Con.Aux(n);_;Con.ArgProof proof;_] -> proof
- | _ -> assert false;
- (*
- List.map (ContentPp.parg 0) conclude.Con.conclude_args;
- assert false *)) in
- match proof.Con.proof_context with
- `Declaration decl::`Hypothesis hyp::tl
- | `Hypothesis decl::`Hypothesis hyp::tl ->
- let get_name decl =
- (match decl.Con.dec_name with
- None -> "_"
- | Some s -> s) in
- let presdecl =
- B.H ([],
- [(B.b_kw "let");
- B.skip;
- B.Object ([], P.Mi([],get_name decl));
- B.Text([],":"); term2pres decl.Con.dec_type]) in
- let suchthat =
- B.H ([],
- [(B.b_kw "such that");
- B.skip;
- B.Text([],"(");
- B.Object ([], P.Mi([],get_name hyp));
- B.Text([],")");
- B.skip;
- term2pres hyp.Con.dec_type]) in
- (* let body = proof2pres {proof with Con.proof_context = tl} in *)
- let body = conclude2pres proof.Con.proof_conclude false true in
- let presacontext =
- acontext2pres proof.Con.proof_apply_context body false in
- B.V
- ([],
- [presdecl;
- suchthat;
- presacontext]);
- | _ -> assert false
-
- in
- proof2pres p
-
-exception ToDo
-
-let counter = ref 0
-
-let conjecture2pres term2pres (id, n, context, ty) =
- (B.b_h [Some "helm", "xref", id]
- (((List.map
- (function
- | None ->
- B.b_h []
- [ B.b_object (p_mi [] "_") ;
- B.b_object (p_mo [] ":?") ;
- B.b_object (p_mi [] "_")]
- | Some (`Declaration d)
- | Some (`Hypothesis d) ->
- let { Content.dec_name =
- dec_name ; Content.dec_type = ty } = d
- in
- B.b_h []
- [ B.b_object
- (p_mi []
- (match dec_name with
- None -> "_"
- | Some n -> n));
- B.b_text [] ":";
- term2pres ty ]
- | Some (`Definition d) ->
- let
- { Content.def_name = def_name ;
- Content.def_term = bo } = d
- in
- B.b_h []
- [ B.b_object (p_mi []
- (match def_name with
- None -> "_"
- | Some n -> n)) ;
- B.b_text [] (Utf8Macro.unicode_of_tex "\\Assign");
- term2pres bo]
- | Some (`Proof p) ->
- let proof_name = p.Content.proof_name in
- B.b_h []
- [ B.b_object (p_mi []
- (match proof_name with
- None -> "_"
- | Some n -> n)) ;
- B.b_text [] (Utf8Macro.unicode_of_tex "\\Assign");
- proof2pres term2pres p])
- (List.rev context)) @
- [ B.b_text [] (Utf8Macro.unicode_of_tex "\\vdash");
- B.b_object (p_mi [] (string_of_int n)) ;
- B.b_text [] ":" ;
- term2pres ty ])))
-
-let metasenv2pres term2pres = function
- | None -> []
- | Some metasenv' ->
- (* Conjectures are in their own table to make *)
- (* diffing the DOM trees easier. *)
- [B.b_v []
- ((B.b_kw ("Conjectures:" ^
- (let _ = incr counter; in (string_of_int !counter)))) ::
- (List.map (conjecture2pres term2pres) metasenv'))]
-
-let params2pres params =
- let param2pres uri =
- B.b_text [Some "xlink", "href", UriManager.string_of_uri uri]
- (UriManager.name_of_uri uri)
- in
- let rec spatiate = function
- | [] -> []
- | hd :: [] -> [hd]
- | hd :: tl -> hd :: B.b_text [] ", " :: spatiate tl
- in
- match params with
- | [] -> []
- | p ->
- let params = spatiate (List.map param2pres p) in
- [B.b_space;
- B.b_h [] (B.b_text [] "[" :: params @ [ B.b_text [] "]" ])]
-
-let recursion_kind2pres params kind =
- let kind =
- match kind with
- | `Recursive _ -> "Recursive definition"
- | `CoRecursive -> "CoRecursive definition"
- | `Inductive _ -> "Inductive definition"
- | `CoInductive _ -> "CoInductive definition"
- in
- B.b_h [] (B.b_kw kind :: params2pres params)
-
-let inductive2pres term2pres ind =
- let constructor2pres decl =
- B.b_h [] [
- B.b_text [] ("| " ^ get_name decl.Content.dec_name ^ ":");
- B.b_space;
- term2pres decl.Content.dec_type
- ]
- in
- B.b_v []
- (B.b_h [] [
- B.b_kw (ind.Content.inductive_name ^ " of arity");
- B.smallskip;
- term2pres ind.Content.inductive_type ]
- :: List.map constructor2pres ind.Content.inductive_constructors)
-
-let joint_def2pres term2pres def =
- match def with
- | `Inductive ind -> inductive2pres term2pres ind
- | _ -> assert false (* ZACK or raise ToDo? *)
-
-let content2pres term2pres (id,params,metasenv,obj) =
- match obj with
- | `Def (Content.Const, thesis, `Proof p) ->
- let name = get_name p.Content.proof_name in
- B.b_v
- [Some "helm","xref","id"]
- ([ B.b_h [] (B.b_kw ("Proof " ^ name) :: params2pres params);
- B.b_kw "Thesis:";
- B.indent (term2pres thesis) ] @
- metasenv2pres term2pres metasenv @
- [proof2pres term2pres p])
- | `Def (_, ty, `Definition body) ->
- let name = get_name body.Content.def_name in
- B.b_v
- [Some "helm","xref","id"]
- ([B.b_h [] (B.b_kw ("Definition " ^ name) :: params2pres params);
- B.b_kw "Type:";
- B.indent (term2pres ty)] @
- metasenv2pres term2pres metasenv @
- [B.b_kw "Body:"; term2pres body.Content.def_term])
- | `Decl (_, `Declaration decl)
- | `Decl (_, `Hypothesis decl) ->
- let name = get_name decl.Content.dec_name in
- B.b_v
- [Some "helm","xref","id"]
- ([B.b_h [] (B.b_kw ("Axiom " ^ name) :: params2pres params);
- B.b_kw "Type:";
- B.indent (term2pres decl.Content.dec_type)] @
- metasenv2pres term2pres metasenv)
- | `Joint joint ->
- B.b_v []
- (recursion_kind2pres params joint.Content.joint_kind
- :: List.map (joint_def2pres term2pres) joint.Content.joint_defs)
- | _ -> raise ToDo
-
-let content2pres ~ids_to_inner_sorts =
- content2pres
- (fun annterm ->
- let ast, ids_to_uris =
- CicNotationRew.ast_of_acic ids_to_inner_sorts annterm
- in
- CicNotationPres.box_of_mpres
- (CicNotationPres.render ids_to_uris
- (CicNotationRew.pp_ast ast)))
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(**************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 27/6/2003 *)
-(* *)
-(**************************************************************************)
-
-val content2pres:
- ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t ->
- Cic.annterm Content.cobj ->
- CicNotationPres.boxml_markup
-
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(******************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
-(* 06/01/2002 *)
-(* *)
-(* *)
-(******************************************************************************)
-
-let domImpl = Gdome.domImplementation ()
-let helm_ns = Gdome.domString "http://www.cs.unibo.it/helm"
-let xlink_ns = Gdome.domString "http://www.w3.org/1999/xlink"
-let mathml_ns = Gdome.domString "http://www.w3.org/1998/Math/MathML"
-let boxml_ns = Gdome.domString "http://helm.cs.unibo.it/2003/BoxML"
-
- (* TODO BRRRRR .... *)
- (** strip first 4 line of a string, used to strip xml declaration and doctype
- declaration from XML strings generated by Xml.pp_to_string *)
-let strip_xml_headings =
- let xml_headings_RE = Pcre.regexp "^.*\n.*\n.*\n.*\n" in
- fun s ->
- Pcre.replace ~rex:xml_headings_RE s
-
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(******************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
-(* 15/01/2003 *)
-(* *)
-(* *)
-(******************************************************************************)
-
-(* TODO rename this module into at least something like CicMisc *)
-
-val domImpl : Gdome.domImplementation
-
-val helm_ns : Gdome.domString (** HELM namespace *)
-val xlink_ns : Gdome.domString (** XLink namespace *)
-val mathml_ns : Gdome.domString (** MathML namespace *)
-val boxml_ns : Gdome.domString (** BoxML namespace *)
-
-val strip_xml_headings: string -> string
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(***************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 19/11/2003 *)
-(* *)
-(***************************************************************************)
-
-let p_mtr a b = Mpresentation.Mtr(a,b)
-let p_mtd a b = Mpresentation.Mtd(a,b)
-let p_mtable a b = Mpresentation.Mtable(a,b)
-let p_mtext a b = Mpresentation.Mtext(a,b)
-let p_mi a b = Mpresentation.Mi(a,b)
-let p_mo a b = Mpresentation.Mo(a,b)
-let p_mrow a b = Mpresentation.Mrow(a,b)
-let p_mphantom a b = Mpresentation.Mphantom(a,b)
-let b_ink a = Box.Ink a
-
-module K = Content
-module P = Mpresentation
-
-let sequent2pres term2pres (_,_,context,ty) =
- let context2pres context =
- let rec aux accum =
- function
- [] -> accum
- | None::tl -> aux accum tl
- | (Some (`Declaration d))::tl ->
- let
- { K.dec_name = dec_name ;
- K.dec_id = dec_id ;
- K.dec_type = ty } = d in
- let r =
- Box.b_h [Some "helm", "xref", dec_id]
- [ Box.b_object (p_mi []
- (match dec_name with
- None -> "_"
- | Some n -> n)) ;
- Box.b_text [] ":" ;
- term2pres ty] in
- aux (r::accum) tl
- | (Some (`Definition d))::tl ->
- let
- { K.def_name = def_name ;
- K.def_id = def_id ;
- K.def_term = bo } = d in
- let r =
- Box.b_h [Some "helm", "xref", def_id]
- [ Box.b_object (p_mi []
- (match def_name with
- None -> "_"
- | Some n -> n)) ;
- Box.b_text [] (Utf8Macro.unicode_of_tex "\\def") ;
- term2pres bo] in
- aux (r::accum) tl
- | _::_ -> assert false in
- aux [] context in
- let pres_context = (Box.b_v [] (context2pres context)) in
- let pres_goal = term2pres ty in
- (Box.b_h [] [
- Box.b_space;
- (Box.b_v []
- [Box.b_space;
- pres_context;
- b_ink [None,"width","4cm"; None,"height","2px"]; (* sequent line *)
- Box.b_space;
- pres_goal])])
-
-let sequent2pres ~ids_to_inner_sorts =
- sequent2pres
- (fun annterm ->
- let ast, ids_to_uris =
- CicNotationRew.ast_of_acic ids_to_inner_sorts annterm
- in
- CicNotationPres.box_of_mpres
- (CicNotationPres.render ids_to_uris
- (CicNotationRew.pp_ast ast)))
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(***************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 19/11/2003 *)
-(* *)
-(***************************************************************************)
-
-val sequent2pres :
- ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t ->
- Cic.annterm Content.conjecture ->
- CicNotationPres.boxml_markup
-
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-let document_of_xml (domImplementation : Gdome.domImplementation) strm =
- let module G = Gdome in
- let module X = Xml in
- let rec update_namespaces ((defaultns,bindings) as namespaces) =
- function
- [] -> namespaces
- | (None,"xmlns",value)::tl ->
- update_namespaces (Some (Gdome.domString value),bindings) tl
- | (prefix,name,value)::tl when prefix = Some "xmlns" ->
- update_namespaces (defaultns,(name,Gdome.domString value)::bindings) tl
- | _::tl -> update_namespaces namespaces tl in
- let rec namespace_of_prefix (defaultns,bindings) =
- function
- None -> None
- | Some "xmlns" -> Some (Gdome.domString "xml-ns")
- | Some p' ->
- try
- Some (List.assoc p' bindings)
- with
- Not_found ->
- raise
- (Failure ("The prefix " ^ p' ^ " is not bound to any namespace")) in
- let get_qualified_name p n =
- match p with
- None -> Gdome.domString n
- | Some p' -> Gdome.domString (p' ^ ":" ^ n) in
- let root_prefix,root_name,root_attributes,root_content =
- ignore (Stream.next strm) ; (* to skip the <?xml ...?> declaration *)
- ignore (Stream.next strm) ; (* to skip the DOCTYPE declaration *)
- match Stream.next strm with
- X.Empty(p,n,l) -> p,n,l,[<>]
- | X.NEmpty(p,n,l,c) -> p,n,l,c
- | _ -> assert false
- in
- let namespaces = update_namespaces (None,[]) root_attributes in
- let namespaceURI = namespace_of_prefix namespaces root_prefix in
- let document =
- domImplementation#createDocument ~namespaceURI
- ~qualifiedName:(get_qualified_name root_prefix root_name)
- ~doctype:None
- in
- let rec aux namespaces (node : Gdome.node) =
- parser
- [< 'X.Str a ; s >] ->
- let textnode = document#createTextNode ~data:(Gdome.domString a) in
- ignore (node#appendChild ~newChild:(textnode :> Gdome.node)) ;
- aux namespaces node s
- | [< 'X.Empty(p,n,l) ; s >] ->
- let namespaces' = update_namespaces namespaces l in
- let namespaceURI = namespace_of_prefix namespaces' p in
- let element =
- document#createElementNS ~namespaceURI
- ~qualifiedName:(get_qualified_name p n)
- in
- List.iter
- (function (p,n,v) ->
- if p = None then
- element#setAttribute ~name:(Gdome.domString n)
- ~value:(Gdome.domString v)
- else
- let namespaceURI = namespace_of_prefix namespaces' p in
- element#setAttributeNS
- ~namespaceURI
- ~qualifiedName:(get_qualified_name p n)
- ~value:(Gdome.domString v)
- ) l ;
- ignore
- (node#appendChild
- ~newChild:(element : Gdome.element :> Gdome.node)) ;
- aux namespaces node s
- | [< 'X.NEmpty(p,n,l,c) ; s >] ->
- let namespaces' = update_namespaces namespaces l in
- let namespaceURI = namespace_of_prefix namespaces' p in
- let element =
- document#createElementNS ~namespaceURI
- ~qualifiedName:(get_qualified_name p n)
- in
- List.iter
- (function (p,n,v) ->
- if p = None then
- element#setAttribute ~name:(Gdome.domString n)
- ~value:(Gdome.domString v)
- else
- let namespaceURI = namespace_of_prefix namespaces' p in
- element#setAttributeNS ~namespaceURI
- ~qualifiedName:(get_qualified_name p n)
- ~value:(Gdome.domString v)
- ) l ;
- ignore (node#appendChild ~newChild:(element :> Gdome.node)) ;
- aux namespaces' (element :> Gdome.node) c ;
- aux namespaces node s
- | [< >] -> ()
- in
- let root = document#get_documentElement in
- List.iter
- (function (p,n,v) ->
- if p = None then
- root#setAttribute ~name:(Gdome.domString n)
- ~value:(Gdome.domString v)
- else
- let namespaceURI = namespace_of_prefix namespaces p in
- root#setAttributeNS ~namespaceURI
- ~qualifiedName:(get_qualified_name p n)
- ~value:(Gdome.domString v)
- ) root_attributes ;
- aux namespaces (root : Gdome.element :> Gdome.node) root_content ;
- document
-;;
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM 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; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM 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 HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val document_of_xml :
- Gdome.domImplementation -> Xml.token Stream.t -> Gdome.document
--- /dev/null
+*.cm[iaox]
+*.cmxa
+test_lexer
+test_lexer.opt
--- /dev/null
+cicNotationPres.cmi: mpresentation.cmi box.cmi
+boxPp.cmi: cicNotationPres.cmi
+content2pres.cmi: cicNotationPres.cmi
+sequent2pres.cmi: cicNotationPres.cmi
+renderingAttrs.cmo: renderingAttrs.cmi
+renderingAttrs.cmx: renderingAttrs.cmi
+cicNotationLexer.cmo: cicNotationLexer.cmi
+cicNotationLexer.cmx: cicNotationLexer.cmi
+cicNotationParser.cmo: cicNotationLexer.cmi cicNotationParser.cmi
+cicNotationParser.cmx: cicNotationLexer.cmx cicNotationParser.cmi
+mpresentation.cmo: mpresentation.cmi
+mpresentation.cmx: mpresentation.cmi
+box.cmo: renderingAttrs.cmi box.cmi
+box.cmx: renderingAttrs.cmx box.cmi
+content2presMatcher.cmo: content2presMatcher.cmi
+content2presMatcher.cmx: content2presMatcher.cmi
+termContentPres.cmo: renderingAttrs.cmi content2presMatcher.cmi \
+ termContentPres.cmi
+termContentPres.cmx: renderingAttrs.cmx content2presMatcher.cmx \
+ termContentPres.cmi
+cicNotationPres.cmo: renderingAttrs.cmi mpresentation.cmi box.cmi \
+ cicNotationPres.cmi
+cicNotationPres.cmx: renderingAttrs.cmx mpresentation.cmx box.cmx \
+ cicNotationPres.cmi
+boxPp.cmo: renderingAttrs.cmi mpresentation.cmi cicNotationPres.cmi box.cmi \
+ boxPp.cmi
+boxPp.cmx: renderingAttrs.cmx mpresentation.cmx cicNotationPres.cmx box.cmx \
+ boxPp.cmi
+content2pres.cmo: renderingAttrs.cmi mpresentation.cmi cicNotationPres.cmi \
+ box.cmi content2pres.cmi
+content2pres.cmx: renderingAttrs.cmx mpresentation.cmx cicNotationPres.cmx \
+ box.cmx content2pres.cmi
+sequent2pres.cmo: mpresentation.cmi cicNotationPres.cmi box.cmi \
+ sequent2pres.cmi
+sequent2pres.cmx: mpresentation.cmx cicNotationPres.cmx box.cmx \
+ sequent2pres.cmi
--- /dev/null
+PACKAGE = content_pres
+PREDICATES =
+
+INTERFACE_FILES = \
+ renderingAttrs.mli \
+ cicNotationLexer.mli \
+ cicNotationParser.mli \
+ mpresentation.mli \
+ box.mli \
+ content2presMatcher.mli \
+ termContentPres.mli \
+ cicNotationPres.mli \
+ boxPp.mli \
+ content2pres.mli \
+ sequent2pres.mli \
+ $(NULL)
+IMPLEMENTATION_FILES = \
+ $(INTERFACE_FILES:%.mli=%.ml)
+
+cicNotationPres.cmi: OCAMLOPTIONS += -rectypes
+cicNotationPres.cmo: OCAMLOPTIONS += -rectypes
+cicNotationPres.cmx: OCAMLOPTIONS += -rectypes
+
+all: test_lexer
+clean: clean_tests
+
+LOCAL_LINKOPTS = -package helm-content_pres -linkpkg
+test: test_lexer
+test_lexer: test_lexer.ml $(PACKAGE).cma
+ $(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
+
+clean_tests:
+ rm -f test_lexer{,.opt}
+
+cicNotationLexer.cmo: OCAMLC = $(OCAMLC_P4)
+cicNotationParser.cmo: OCAMLC = $(OCAMLC_P4)
+cicNotationLexer.cmx: OCAMLOPT = $(OCAMLOPT_P4)
+cicNotationParser.cmx: OCAMLOPT = $(OCAMLOPT_P4)
+cicNotationLexer.ml.annot: OCAMLC = $(OCAMLC_P4)
+cicNotationParser.ml.annot: OCAMLC = $(OCAMLC_P4)
+
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2000-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(*************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Andrea Asperti <asperti@cs.unibo.it> *)
+(* 13/2/2004 *)
+(* *)
+(*************************************************************************)
+
+type
+ 'expr box =
+ Text of attr * string
+ | Space of attr
+ | Ink of attr
+ | H of attr * ('expr box) list
+ | V of attr * ('expr box) list
+ | HV of attr * ('expr box) list
+ | HOV of attr * ('expr box) list
+ | Object of attr * 'expr
+ | Action of attr * ('expr box) list
+
+and attr = (string option * string * string) list
+
+let smallskip = Space([None,"width","0.5em"]);;
+let skip = Space([None,"width","1em"]);;
+
+let indent t = H([],[skip;t]);;
+
+(* BoxML prefix *)
+let prefix = "b";;
+
+let tag_of_box = function
+ | H _ -> "h"
+ | V _ -> "v"
+ | HV _ -> "hv"
+ | HOV _ -> "hov"
+ | _ -> assert false
+
+let box2xml ~obj2xml box =
+ let rec aux =
+ let module X = Xml in
+ function
+ Text (attr,s) -> X.xml_nempty ~prefix "text" attr (X.xml_cdata s)
+ | Space attr -> X.xml_empty ~prefix "space" attr
+ | Ink attr -> X.xml_empty ~prefix "ink" attr
+ | H (attr,l)
+ | V (attr,l)
+ | HV (attr,l)
+ | HOV (attr,l) as box ->
+ X.xml_nempty ~prefix (tag_of_box box) attr
+ [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>])
+ >]
+ | Object (attr,m) ->
+ X.xml_nempty ~prefix "obj" attr [< obj2xml m >]
+ | Action (attr,l) ->
+ X.xml_nempty ~prefix "action" attr
+ [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) >]
+ in
+ aux box
+;;
+
+let rec map f = function
+ | (Text _) as box -> box
+ | (Space _) as box -> box
+ | (Ink _) as box -> box
+ | H (attr, l) -> H (attr, List.map (map f) l)
+ | V (attr, l) -> V (attr, List.map (map f) l)
+ | HV (attr, l) -> HV (attr, List.map (map f) l)
+ | HOV (attr, l) -> HOV (attr, List.map (map f) l)
+ | Action (attr, l) -> Action (attr, List.map (map f) l)
+ | Object (attr, obj) -> Object (attr, f obj)
+;;
+
+(*
+let document_of_box ~obj2xml pres =
+ [< Xml.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ Xml.xml_cdata "\n";
+ Xml.xml_nempty ~prefix "box"
+ [Some "xmlns","m","http://www.w3.org/1998/Math/MathML" ;
+ Some "xmlns","b","http://helm.cs.unibo.it/2003/BoxML" ;
+ Some "xmlns","helm","http://www.cs.unibo.it/helm" ;
+ Some "xmlns","xlink","http://www.w3.org/1999/xlink"
+ ] (print_box pres)
+ >]
+*)
+
+let b_h a b = H(a,b)
+let b_v a b = V(a,b)
+let b_hv a b = HV(a,b)
+let b_hov a b = HOV(a,b)
+let b_text a b = Text(a,b)
+let b_object b = Object ([],b)
+let b_indent = indent
+let b_space = Space [None, "width", "0.5em"]
+let b_kw = b_text (RenderingAttrs.object_keyword_attributes `BoxML)
+
+let pp_attr attr =
+ let pp (ns, n, v) =
+ Printf.sprintf "%s%s=%s" (match ns with None -> "" | Some s -> s ^ ":") n v
+ in
+ String.concat " " (List.map pp attr)
+
+let get_attr = function
+ | Text (attr, _)
+ | Space attr
+ | Ink attr
+ | H (attr, _)
+ | V (attr, _)
+ | HV (attr, _)
+ | HOV (attr, _)
+ | Object (attr, _)
+ | Action (attr, _) ->
+ attr
+
+let set_attr attr = function
+ | Text (_, x) -> Text (attr, x)
+ | Space _ -> Space attr
+ | Ink _ -> Ink attr
+ | H (_, x) -> H (attr, x)
+ | V (_, x) -> V (attr, x)
+ | HV (_, x) -> HV (attr, x)
+ | HOV (_, x) -> HOV (attr, x)
+ | Object (_, x) -> Object (attr, x)
+ | Action (_, x) -> Action (attr, x)
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(*************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Andrea Asperti <asperti@cs.unibo.it> *)
+(* 13/2/2004 *)
+(* *)
+(*************************************************************************)
+
+type
+ 'expr box =
+ Text of attr * string
+ | Space of attr
+ | Ink of attr
+ | H of attr * ('expr box) list
+ | V of attr * ('expr box) list
+ | HV of attr * ('expr box) list
+ | HOV of attr * ('expr box) list
+ | Object of attr * 'expr
+ | Action of attr * ('expr box) list
+
+and attr = (string option * string * string) list
+
+val get_attr: 'a box -> attr
+val set_attr: attr -> 'a box -> 'a box
+
+val smallskip : 'expr box
+val skip: 'expr box
+val indent : 'expr box -> 'expr box
+
+val box2xml:
+ obj2xml:('a -> Xml.token Stream.t) -> 'a box ->
+ Xml.token Stream.t
+
+val map: ('a -> 'b) -> 'a box -> 'b box
+
+(*
+val document_of_box :
+ ~obj2xml:('a -> Xml.token Stream.t) -> 'a box -> Xml.token Stream.t
+*)
+
+val b_h: attr -> 'expr box list -> 'expr box
+val b_v: attr -> 'expr box list -> 'expr box
+val b_hv: attr -> 'expr box list -> 'expr box (** default indent and spacing *)
+val b_hov: attr -> 'expr box list -> 'expr box (** default indent and spacing *)
+val b_text: attr -> string -> 'expr box
+val b_object: 'expr -> 'expr box
+val b_indent: 'expr box -> 'expr box
+val b_space: 'expr box
+val b_kw: string -> 'expr box
+
+val pp_attr: attr -> string
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+module Pres = Mpresentation
+
+(** {2 Pretty printing from BoxML to strings} *)
+
+let string_space = " "
+let string_space_len = String.length string_space
+let string_indent = string_space
+let string_indent_len = String.length string_indent
+let string_ink = "##"
+let string_ink_len = String.length string_ink
+
+let contains_attrs contained container =
+ List.for_all (fun attr -> List.mem attr container) contained
+
+let want_indent = contains_attrs (RenderingAttrs.indent_attributes `BoxML)
+let want_spacing = contains_attrs (RenderingAttrs.spacing_attributes `BoxML)
+
+let indent_string s = string_indent ^ s
+let indent_children (size, children) =
+ let children' = List.map indent_string children in
+ size + string_space_len, children'
+
+let choose_rendering size (best, other) =
+ let best_size, _ = best in
+ if size >= best_size then best else other
+
+let merge_columns sep cols =
+ let sep_len = String.length sep in
+ let indent = ref 0 in
+ let res_rows = ref [] in
+ let add_row ~continue row =
+ match !res_rows with
+ | last :: prev when continue ->
+ res_rows := (String.concat sep [last; row]) :: prev;
+ indent := !indent + String.length last + sep_len
+ | _ -> res_rows := (String.make !indent ' ' ^ row) :: !res_rows;
+ in
+ List.iter
+ (fun rows ->
+ match rows with
+ | hd :: tl ->
+ add_row ~continue:true hd;
+ List.iter (add_row ~continue:false) tl
+ | [] -> ())
+ cols;
+ List.rev !res_rows
+
+let max_len =
+ List.fold_left (fun max_size s -> max (String.length s) max_size) 0
+
+let render_row available_space spacing children =
+ let spacing_bonus = if spacing then string_space_len else 0 in
+ let rem_space = ref available_space in
+ let renderings = ref [] in
+ List.iter
+ (fun f ->
+ let occupied_space, rendering = f !rem_space in
+ renderings := rendering :: !renderings;
+ rem_space := !rem_space - (occupied_space + spacing_bonus))
+ children;
+ let sep = if spacing then string_space else "" in
+ let rendering = merge_columns sep (List.rev !renderings) in
+ max_len rendering, rendering
+
+let fixed_rendering s =
+ let s_len = String.length s in
+ (fun _ -> s_len, [s])
+
+let render_to_strings size markup =
+ let max_size = max_int in
+ let rec aux_box =
+ function
+ | Box.Text (_, t) -> fixed_rendering t
+ | Box.Space _ -> fixed_rendering string_space
+ | Box.Ink _ -> fixed_rendering string_ink
+ | Box.Action (_, []) -> assert false
+ | Box.Action (_, hd :: _) -> aux_box hd
+ | Box.Object (_, o) -> aux_mpres o
+ | Box.H (attrs, children) ->
+ let spacing = want_spacing attrs in
+ let children' = List.map aux_box children in
+ (fun size -> render_row size spacing children')
+ | Box.HV (attrs, children) ->
+ let spacing = want_spacing attrs in
+ let children' = List.map aux_box children in
+ (fun size ->
+ let (size', renderings) as res =
+ render_row max_size spacing children'
+ in
+ if size' <= size then (* children fit in a row *)
+ res
+ else (* break needed, re-render using a Box.V *)
+ aux_box (Box.V (attrs, children)) size)
+ | Box.V (attrs, []) -> assert false
+ | Box.V (attrs, [child]) -> aux_box child
+ | Box.V (attrs, hd :: tl) ->
+ let indent = want_indent attrs in
+ let hd_f = aux_box hd in
+ let tl_fs = List.map aux_box tl in
+ (fun size ->
+ let _, hd_rendering = hd_f size in
+ let children_size =
+ max 0 (if indent then size - string_indent_len else size)
+ in
+ let tl_renderings =
+ List.map
+ (fun f ->
+ let indent_header = if indent then string_indent else "" in
+ snd (indent_children (f children_size)))
+ tl_fs
+ in
+ let rows = hd_rendering @ List.concat tl_renderings in
+ max_len rows, rows)
+ | Box.HOV (attrs, []) -> assert false
+ | Box.HOV (attrs, [child]) -> aux_box child
+ | Box.HOV (attrs, children) ->
+ let spacing = want_spacing attrs in
+ let indent = want_indent attrs in
+ let spacing_bonus = if spacing then string_space_len else 0 in
+ let indent_bonus = if indent then string_indent_len else 0 in
+ let sep = if spacing then string_space else "" in
+ let fs = List.map aux_box children in
+ (fun size ->
+ let rows = ref [] in
+ let renderings = ref [] in
+ let rem_space = ref size in
+ let first_row = ref true in
+ let use_rendering (space, rendering) =
+ let use_indent = !renderings = [] && not !first_row in
+ let rendering' =
+ if use_indent then List.map indent_string rendering
+ else rendering
+ in
+ renderings := rendering' :: !renderings;
+ let bonus = if use_indent then indent_bonus else spacing_bonus in
+ rem_space := !rem_space - (space + bonus)
+ in
+ let end_cluster () =
+ let new_rows = merge_columns sep (List.rev !renderings) in
+ rows := List.rev_append new_rows !rows;
+ rem_space := size - indent_bonus;
+ renderings := [];
+ first_row := false
+ in
+ List.iter
+ (fun f ->
+ let (best_space, _) as best = f max_size in
+ if best_space <= !rem_space then
+ use_rendering best
+ else begin
+ end_cluster ();
+ if best_space <= !rem_space then use_rendering best
+ else use_rendering (f size)
+ end)
+ fs;
+ if !renderings <> [] then end_cluster ();
+ max_len !rows, List.rev !rows)
+ and aux_mpres =
+ let text s = Pres.Mtext ([], s) in
+ let mrow c = Pres.Mrow ([], c) in
+ function
+ | Pres.Mi (_, s)
+ | Pres.Mn (_, s)
+ | Pres.Mtext (_, s)
+ | Pres.Ms (_, s)
+ | Pres.Mgliph (_, s) -> fixed_rendering s
+ | Pres.Mo (_, s) ->
+ let s =
+ if String.length s > 1 then
+ (* heuristic to guess which operators need to be expanded in their
+ * TeX like format *)
+ Utf8Macro.tex_of_unicode s ^ " "
+ else s
+ in
+ fixed_rendering s
+ | Pres.Mspace _ -> fixed_rendering string_space
+ | Pres.Mrow (attrs, children) ->
+ let children' = List.map aux_mpres children in
+ (fun size -> render_row size false children')
+ | Pres.Mfrac (_, m, n) ->
+ aux_mpres (mrow [ text "\\frac("; text ")"; text "("; n; text ")" ])
+ | Pres.Msqrt (_, m) -> aux_mpres (mrow [ text "\\sqrt("; m; text ")" ])
+ | Pres.Mroot (_, r, i) ->
+ aux_mpres (mrow [
+ text "\\root("; i; text ")"; text "\\of("; r; text ")" ])
+ | Pres.Mstyle (_, m)
+ | Pres.Merror (_, m)
+ | Pres.Mpadded (_, m)
+ | Pres.Mphantom (_, m)
+ | Pres.Menclose (_, m) -> aux_mpres m
+ | Pres.Mfenced (_, children) -> aux_mpres (mrow children)
+ | Pres.Maction (_, []) -> assert false
+ | Pres.Msub (_, m, n) ->
+ aux_mpres (mrow [ text "("; m; text ")\\sub("; n; text ")" ])
+ | Pres.Msup (_, m, n) ->
+ aux_mpres (mrow [ text "("; m; text ")\\sup("; n; text ")" ])
+ | Pres.Munder (_, m, n) ->
+ aux_mpres (mrow [ text "("; m; text ")\\below("; n; text ")" ])
+ | Pres.Mover (_, m, n) ->
+ aux_mpres (mrow [ text "("; m; text ")\\above("; n; text ")" ])
+ | Pres.Msubsup _
+ | Pres.Munderover _
+ | Pres.Mtable _ ->
+ prerr_endline
+ "MathML presentation element not yet available in concrete syntax";
+ assert false
+ | Pres.Maction (_, hd :: _) -> aux_mpres hd
+ | Pres.Mobject (_, o) -> aux_box (o: CicNotationPres.boxml_markup)
+ in
+ snd (aux_mpres markup size)
+
+let render_to_string size markup =
+ String.concat "\n" (render_to_strings size markup)
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+ (** @return rows list of rows *)
+val render_to_strings: int -> CicNotationPres.markup -> string list
+
+ (** helper function
+ * @return s, concatenation of the return value of render_to_strings above
+ * with newlines as separators *)
+val render_to_string: int -> CicNotationPres.markup -> string
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Printf
+
+exception Error of int * int * string
+
+let regexp number = xml_digit+
+
+ (* ZACK: breaks unicode's binder followed by an ascii letter without blank *)
+(* let regexp ident_letter = xml_letter *)
+
+let regexp ident_letter = [ 'a' - 'z' 'A' - 'Z' ]
+
+ (* must be in sync with "is_ligature_char" below *)
+let regexp ligature_char = [ "'`~!?@*()[]<>-+=|:;.,/\"" ]
+let regexp ligature = ligature_char ligature_char+
+
+let is_ligature_char =
+ (* must be in sync with "regexp ligature_char" above *)
+ let chars = "'`~!?@*()[]<>-+=|:;.,/\"" in
+ (fun char ->
+ (try
+ ignore (String.index chars char);
+ true
+ with Not_found -> false))
+
+let regexp ident_decoration = '\'' | '?' | '`'
+let regexp ident_cont = ident_letter | xml_digit | '_'
+let regexp ident = ident_letter ident_cont* ident_decoration*
+
+let regexp tex_token = '\\' ident
+
+let regexp delim_begin = "\\["
+let regexp delim_end = "\\]"
+
+let regexp qkeyword = "'" ident "'"
+
+let regexp implicit = '?'
+let regexp placeholder = '%'
+let regexp meta = implicit number
+
+let regexp csymbol = '\'' ident
+
+let regexp begin_group = "@{" | "${"
+let regexp end_group = '}'
+let regexp wildcard = "$_"
+let regexp ast_ident = "@" ident
+let regexp ast_csymbol = "@" csymbol
+let regexp meta_ident = "$" ident
+let regexp meta_anonymous = "$_"
+let regexp qstring = '"' [^ '"']* '"'
+
+let regexp begincomment = "(**" xml_blank
+let regexp beginnote = "(*"
+let regexp endcomment = "*)"
+(* let regexp comment_char = [^'*'] | '*'[^')']
+let regexp note = "|+" ([^'*'] | "**") comment_char* "+|" *)
+
+let level1_layouts =
+ [ "sub"; "sup";
+ "below"; "above";
+ "over"; "atop"; "frac";
+ "sqrt"; "root"
+ ]
+
+let level1_keywords =
+ [ "hbox"; "hvbox"; "hovbox"; "vbox";
+ "break";
+ "list0"; "list1"; "sep";
+ "opt";
+ "term"; "ident"; "number"
+ ] @ level1_layouts
+
+let level2_meta_keywords =
+ [ "if"; "then"; "else";
+ "fold"; "left"; "right"; "rec";
+ "fail";
+ "default";
+ "anonymous"; "ident"; "number"; "term"; "fresh"
+ ]
+
+ (* (string, unit) Hashtbl.t, to exploit multiple bindings *)
+let level2_ast_keywords = Hashtbl.create 23
+let _ =
+ List.iter (fun k -> Hashtbl.add level2_ast_keywords k ())
+ [ "CProp"; "Prop"; "Type"; "Set"; "let"; "rec"; "corec"; "match";
+ "with"; "in"; "and"; "to"; "as"; "on"; "return" ]
+
+let add_level2_ast_keyword k = Hashtbl.add level2_ast_keywords k ()
+let remove_level2_ast_keyword k = Hashtbl.remove level2_ast_keywords k
+
+ (* (string, int) Hashtbl.t, with multiple bindings.
+ * int is the unicode codepoint *)
+let ligatures = Hashtbl.create 23
+let _ =
+ List.iter
+ (fun (ligature, symbol) -> Hashtbl.add ligatures ligature symbol)
+ [ ("->", <:unicode<to>>); ("=>", <:unicode<Rightarrow>>);
+ ("<=", <:unicode<leq>>); (">=", <:unicode<geq>>);
+ ("<>", <:unicode<neq>>); (":=", <:unicode<def>>);
+ ]
+
+let regexp uri_step = [ 'a' - 'z' 'A' - 'Z' '0' - '9' '_' '-' ]+
+
+let regexp uri =
+ ("cic:/" | "theory:/") (* schema *)
+(* ident ('/' ident)* |+ path +| *)
+ uri_step ('/' uri_step)* (* path *)
+ ('.' ident)+ (* ext *)
+ ("#xpointer(" number ('/' number)+ ")")? (* xpointer *)
+
+let error lexbuf msg =
+ let begin_cnum, end_cnum = Ulexing.loc lexbuf in
+ raise (Error (begin_cnum, end_cnum, msg))
+let error_at_end lexbuf msg =
+ let begin_cnum, end_cnum = Ulexing.loc lexbuf in
+ raise (Error (begin_cnum, end_cnum, msg))
+
+let return_with_loc token begin_cnum end_cnum =
+ (* TODO handle line/column numbers *)
+ let flocation_begin =
+ { Lexing.pos_fname = "";
+ Lexing.pos_lnum = -1; Lexing.pos_bol = -1;
+ Lexing.pos_cnum = begin_cnum }
+ in
+ let flocation_end = { flocation_begin with Lexing.pos_cnum = end_cnum } in
+ (token, (flocation_begin, flocation_end))
+
+let return lexbuf token =
+ let begin_cnum, end_cnum = Ulexing.loc lexbuf in
+ return_with_loc token begin_cnum end_cnum
+
+let return_lexeme lexbuf name = return lexbuf (name, Ulexing.utf8_lexeme lexbuf)
+
+let return_symbol lexbuf s = return lexbuf ("SYMBOL", s)
+let return_eoi lexbuf = return lexbuf ("EOI", "")
+
+let remove_quotes s = String.sub s 1 (String.length s - 2)
+
+let mk_lexer token =
+ let tok_func stream =
+(* let lexbuf = Ulexing.from_utf8_stream stream in *)
+(** XXX Obj.magic rationale.
+ * The problem.
+ * camlp4 constraints the tok_func field of Token.glexer to have type:
+ * Stream.t char -> (Stream.t 'te * flocation_function)
+ * In order to use ulex we have (in theory) to instantiate a new lexbuf each
+ * time a char Stream.t is passed, destroying the previous lexbuf which may
+ * have consumed a character from the old stream which is lost forever :-(
+ * The "solution".
+ * Instead of passing to camlp4 a char Stream.t we pass a lexbuf, casting it to
+ * char Stream.t with Obj.magic where needed.
+ *)
+ let lexbuf = Obj.magic stream in
+ Token.make_stream_and_flocation
+ (fun () ->
+ try
+ token lexbuf
+ with
+ | Ulexing.Error -> error_at_end lexbuf "Unexpected character"
+ | Ulexing.InvalidCodepoint p ->
+ error_at_end lexbuf (sprintf "Invalid code point: %d" p))
+ in
+ {
+ Token.tok_func = tok_func;
+ Token.tok_using = (fun _ -> ());
+ Token.tok_removing = (fun _ -> ());
+ Token.tok_match = Token.default_match;
+ Token.tok_text = Token.lexer_text;
+ Token.tok_comm = None;
+ }
+
+let expand_macro lexbuf =
+ let macro =
+ Ulexing.utf8_sub_lexeme lexbuf 1 (Ulexing.lexeme_length lexbuf - 1)
+ in
+ try
+ ("SYMBOL", Utf8Macro.expand macro)
+ with Utf8Macro.Macro_not_found _ -> "SYMBOL", Ulexing.utf8_lexeme lexbuf
+
+let remove_quotes s = String.sub s 1 (String.length s - 2)
+let remove_left_quote s = String.sub s 1 (String.length s - 1)
+
+let rec level2_pattern_token_group counter buffer =
+ lexer
+ | end_group ->
+ if (counter > 0) then
+ Buffer.add_string buffer (Ulexing.utf8_lexeme lexbuf) ;
+ snd (Ulexing.loc lexbuf)
+ | begin_group ->
+ Buffer.add_string buffer (Ulexing.utf8_lexeme lexbuf) ;
+ ignore (level2_pattern_token_group (counter + 1) buffer lexbuf) ;
+ level2_pattern_token_group counter buffer lexbuf
+ | _ ->
+ Buffer.add_string buffer (Ulexing.utf8_lexeme lexbuf) ;
+ level2_pattern_token_group counter buffer lexbuf
+
+let read_unparsed_group token_name lexbuf =
+ let buffer = Buffer.create 16 in
+ let begin_cnum, _ = Ulexing.loc lexbuf in
+ let end_cnum = level2_pattern_token_group 0 buffer lexbuf in
+ return_with_loc (token_name, Buffer.contents buffer) begin_cnum end_cnum
+
+let rec level2_meta_token =
+ lexer
+ | xml_blank+ -> level2_meta_token lexbuf
+ | ident ->
+ let s = Ulexing.utf8_lexeme lexbuf in
+ begin
+ if List.mem s level2_meta_keywords then
+ return lexbuf ("", s)
+ else
+ return lexbuf ("IDENT", s)
+ end
+ | "@{" -> read_unparsed_group "UNPARSED_AST" lexbuf
+ | ast_ident ->
+ return lexbuf ("UNPARSED_AST",
+ remove_left_quote (Ulexing.utf8_lexeme lexbuf))
+ | ast_csymbol ->
+ return lexbuf ("UNPARSED_AST",
+ remove_left_quote (Ulexing.utf8_lexeme lexbuf))
+ | eof -> return_eoi lexbuf
+
+let rec comment_token acc depth =
+ lexer
+ | beginnote ->
+ let acc = acc ^ Ulexing.utf8_lexeme lexbuf in
+ comment_token acc (depth + 1) lexbuf
+ | endcomment ->
+ let acc = acc ^ Ulexing.utf8_lexeme lexbuf in
+ if depth = 0
+ then acc
+ else comment_token acc (depth - 1) lexbuf
+ | _ ->
+ let acc = acc ^ Ulexing.utf8_lexeme lexbuf in
+ comment_token acc depth lexbuf
+
+ (** @param k continuation to be invoked when no ligature has been found *)
+let rec ligatures_token k =
+ lexer
+ | ligature ->
+ let lexeme = Ulexing.utf8_lexeme lexbuf in
+ (match List.rev (Hashtbl.find_all ligatures lexeme) with
+ | [] -> (* ligature not found, rollback and try default lexer *)
+ Ulexing.rollback lexbuf;
+ k lexbuf
+ | default_lig :: _ -> (* ligatures found, use the default one *)
+ return_symbol lexbuf default_lig)
+ | eof -> return_eoi lexbuf
+ | _ -> (* not a ligature, rollback and try default lexer *)
+ Ulexing.rollback lexbuf;
+ k lexbuf
+
+and level2_ast_token =
+ lexer
+ | xml_blank+ -> ligatures_token level2_ast_token lexbuf
+ | meta -> return lexbuf ("META", Ulexing.utf8_lexeme lexbuf)
+ | implicit -> return lexbuf ("IMPLICIT", "")
+ | placeholder -> return lexbuf ("PLACEHOLDER", "")
+ | ident ->
+ let lexeme = Ulexing.utf8_lexeme lexbuf in
+ if Hashtbl.mem level2_ast_keywords lexeme then
+ return lexbuf ("", lexeme)
+ else
+ return lexbuf ("IDENT", lexeme)
+ | number -> return lexbuf ("NUMBER", Ulexing.utf8_lexeme lexbuf)
+ | tex_token -> return lexbuf (expand_macro lexbuf)
+ | uri -> return lexbuf ("URI", Ulexing.utf8_lexeme lexbuf)
+ | qstring ->
+ return lexbuf ("QSTRING", remove_quotes (Ulexing.utf8_lexeme lexbuf))
+ | csymbol ->
+ return lexbuf ("CSYMBOL", remove_left_quote (Ulexing.utf8_lexeme lexbuf))
+ | "${" -> read_unparsed_group "UNPARSED_META" lexbuf
+ | "@{" -> read_unparsed_group "UNPARSED_AST" lexbuf
+ | '(' -> return lexbuf ("LPAREN", "")
+ | ')' -> return lexbuf ("RPAREN", "")
+ | meta_ident ->
+ return lexbuf ("UNPARSED_META",
+ remove_left_quote (Ulexing.utf8_lexeme lexbuf))
+ | meta_anonymous -> return lexbuf ("UNPARSED_META", "anonymous")
+ | beginnote ->
+ let comment = comment_token (Ulexing.utf8_lexeme lexbuf) 0 lexbuf in
+(* let comment =
+ Ulexing.utf8_sub_lexeme lexbuf 2 (Ulexing.lexeme_length lexbuf - 4)
+ in
+ return lexbuf ("NOTE", comment) *)
+ ligatures_token level2_ast_token lexbuf
+ | begincomment -> return lexbuf ("BEGINCOMMENT","")
+ | endcomment -> return lexbuf ("ENDCOMMENT","")
+ | eof -> return_eoi lexbuf
+ | _ -> return_symbol lexbuf (Ulexing.utf8_lexeme lexbuf)
+
+and level1_pattern_token =
+ lexer
+ | xml_blank+ -> ligatures_token level1_pattern_token lexbuf
+ | number -> return lexbuf ("NUMBER", Ulexing.utf8_lexeme lexbuf)
+ | ident ->
+ let s = Ulexing.utf8_lexeme lexbuf in
+ begin
+ if List.mem s level1_keywords then
+ return lexbuf ("", s)
+ else
+ return lexbuf ("IDENT", s)
+ end
+ | tex_token -> return lexbuf (expand_macro lexbuf)
+ | qkeyword ->
+ return lexbuf ("QKEYWORD", remove_quotes (Ulexing.utf8_lexeme lexbuf))
+ | '(' -> return lexbuf ("LPAREN", "")
+ | ')' -> return lexbuf ("RPAREN", "")
+ | eof -> return_eoi lexbuf
+ | _ -> return_symbol lexbuf (Ulexing.utf8_lexeme lexbuf)
+
+let level1_pattern_token = ligatures_token level1_pattern_token
+let level2_ast_token = ligatures_token level2_ast_token
+
+(* API implementation *)
+
+let level1_pattern_lexer = mk_lexer level1_pattern_token
+let level2_ast_lexer = mk_lexer level2_ast_token
+let level2_meta_lexer = mk_lexer level2_meta_token
+
+let lookup_ligatures lexeme =
+ try
+ if lexeme.[0] = '\\'
+ then [ Utf8Macro.expand (String.sub lexeme 1 (String.length lexeme - 1)) ]
+ else List.rev (Hashtbl.find_all ligatures lexeme)
+ with Invalid_argument _ | Utf8Macro.Macro_not_found _ as exn -> []
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+ (** begin of error offset (counted in unicode codepoint)
+ * end of error offset (counted as above)
+ * error message *)
+exception Error of int * int * string
+
+ (** XXX ZACK DEFCON 4 BEGIN: never use the tok_func field of the glexers below
+ * passing values of type char Stream.t, they should be in fact Ulexing.lexbuf
+ * casted with Obj.magic :-/ Read the comment in the .ml for the rationale *)
+
+val level1_pattern_lexer: (string * string) Token.glexer
+val level2_ast_lexer: (string * string) Token.glexer
+val level2_meta_lexer: (string * string) Token.glexer
+
+ (** XXX ZACK DEFCON 4 END *)
+
+val add_level2_ast_keyword: string -> unit (** non idempotent *)
+val remove_level2_ast_keyword: string -> unit (** non idempotent *)
+
+(** {2 Ligatures} *)
+
+val is_ligature_char: char -> bool
+val lookup_ligatures: string -> string list
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Printf
+
+module Ast = CicNotationPt
+module Env = CicNotationEnv
+
+exception Parse_error of string
+exception Level_not_found of int
+
+let level1_pattern_grammar =
+ Grammar.gcreate CicNotationLexer.level1_pattern_lexer
+let level2_ast_grammar = Grammar.gcreate CicNotationLexer.level2_ast_lexer
+let level2_meta_grammar = Grammar.gcreate CicNotationLexer.level2_meta_lexer
+
+let min_precedence = 0
+let max_precedence = 100
+
+let level1_pattern =
+ Grammar.Entry.create level1_pattern_grammar "level1_pattern"
+let level2_ast = Grammar.Entry.create level2_ast_grammar "level2_ast"
+let term = Grammar.Entry.create level2_ast_grammar "term"
+let let_defs = Grammar.Entry.create level2_ast_grammar "let_defs"
+let level2_meta = Grammar.Entry.create level2_meta_grammar "level2_meta"
+
+let int_of_string s =
+ try
+ Pervasives.int_of_string s
+ with Failure _ ->
+ failwith (sprintf "Lexer failure: string_of_int \"%s\" failed" s)
+
+(** {2 Grammar extension} *)
+
+let gram_symbol s = Gramext.Stoken ("SYMBOL", s)
+let gram_ident s = Gramext.Stoken ("IDENT", s)
+let gram_number s = Gramext.Stoken ("NUMBER", s)
+let gram_keyword s = Gramext.Stoken ("", s)
+let gram_term = Gramext.Sself
+
+let gram_of_literal =
+ function
+ | `Symbol s -> gram_symbol s
+ | `Keyword s -> gram_keyword s
+ | `Number s -> gram_number s
+
+type binding =
+ | NoBinding
+ | Binding of string * Env.value_type
+ | Env of (string * Env.value_type) list
+
+let make_action action bindings =
+ let rec aux (vl : CicNotationEnv.t) =
+ function
+ [] -> Gramext.action (fun (loc: Ast.location) -> action vl loc)
+ | NoBinding :: tl -> Gramext.action (fun _ -> aux vl tl)
+ (* LUCA: DEFCON 3 BEGIN *)
+ | Binding (name, Env.TermType) :: tl ->
+ Gramext.action
+ (fun (v:Ast.term) ->
+ aux ((name, (Env.TermType, Env.TermValue v))::vl) tl)
+ | Binding (name, Env.StringType) :: tl ->
+ Gramext.action
+ (fun (v:string) ->
+ aux ((name, (Env.StringType, Env.StringValue v)) :: vl) tl)
+ | Binding (name, Env.NumType) :: tl ->
+ Gramext.action
+ (fun (v:string) ->
+ aux ((name, (Env.NumType, Env.NumValue v)) :: vl) tl)
+ | Binding (name, Env.OptType t) :: tl ->
+ Gramext.action
+ (fun (v:'a option) ->
+ aux ((name, (Env.OptType t, Env.OptValue v)) :: vl) tl)
+ | Binding (name, Env.ListType t) :: tl ->
+ Gramext.action
+ (fun (v:'a list) ->
+ aux ((name, (Env.ListType t, Env.ListValue v)) :: vl) tl)
+ | Env _ :: tl ->
+ Gramext.action (fun (v:CicNotationEnv.t) -> aux (v @ vl) tl)
+ (* LUCA: DEFCON 3 END *)
+ in
+ aux [] (List.rev bindings)
+
+let flatten_opt =
+ let rec aux acc =
+ function
+ [] -> List.rev acc
+ | NoBinding :: tl -> aux acc tl
+ | Env names :: tl -> aux (List.rev names @ acc) tl
+ | Binding (name, ty) :: tl -> aux ((name, ty) :: acc) tl
+ in
+ aux []
+
+ (* given a level 1 pattern computes the new RHS of "term" grammar entry *)
+let extract_term_production pattern =
+ let rec aux = function
+ | Ast.AttributedTerm (_, t) -> aux t
+ | Ast.Literal l -> aux_literal l
+ | Ast.Layout l -> aux_layout l
+ | Ast.Magic m -> aux_magic m
+ | Ast.Variable v -> aux_variable v
+ | t ->
+ prerr_endline (CicNotationPp.pp_term t);
+ assert false
+ and aux_literal =
+ function
+ | `Symbol s -> [NoBinding, gram_symbol s]
+ | `Keyword s ->
+ (* assumption: s will be registered as a keyword with the lexer *)
+ [NoBinding, gram_keyword s]
+ | `Number s -> [NoBinding, gram_number s]
+ and aux_layout = function
+ | Ast.Sub (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\sub"] @ aux p2
+ | Ast.Sup (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\sup"] @ aux p2
+ | Ast.Below (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\below"] @ aux p2
+ | Ast.Above (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\above"] @ aux p2
+ | Ast.Frac (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\frac"] @ aux p2
+ | Ast.Atop (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\atop"] @ aux p2
+ | Ast.Over (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\over"] @ aux p2
+ | Ast.Root (p1, p2) ->
+ [NoBinding, gram_symbol "\\root"] @ aux p2
+ @ [NoBinding, gram_symbol "\\of"] @ aux p1
+ | Ast.Sqrt p -> [NoBinding, gram_symbol "\\sqrt"] @ aux p
+ | Ast.Break -> []
+ | Ast.Box (_, pl) -> List.flatten (List.map aux pl)
+ | Ast.Group pl -> List.flatten (List.map aux pl)
+ and aux_magic magic =
+ match magic with
+ | Ast.Opt p ->
+ let p_bindings, p_atoms, p_names, p_action = inner_pattern p in
+ let action (env_opt : CicNotationEnv.t option) (loc : Ast.location) =
+ match env_opt with
+ | Some env -> List.map Env.opt_binding_some env
+ | None -> List.map Env.opt_binding_of_name p_names
+ in
+ [ Env (List.map Env.opt_declaration p_names),
+ Gramext.srules
+ [ [ Gramext.Sopt (Gramext.srules [ p_atoms, p_action ]) ],
+ Gramext.action action ] ]
+ | Ast.List0 (p, _)
+ | Ast.List1 (p, _) ->
+ let p_bindings, p_atoms, p_names, p_action = inner_pattern p in
+(* let env0 = List.map list_binding_of_name p_names in
+ let grow_env_entry env n v =
+ List.map
+ (function
+ | (n', (ty, ListValue vl)) as entry ->
+ if n' = n then n', (ty, ListValue (v :: vl)) else entry
+ | _ -> assert false)
+ env
+ in
+ let grow_env env_i env =
+ List.fold_left
+ (fun env (n, (_, v)) -> grow_env_entry env n v)
+ env env_i
+ in *)
+ let action (env_list : CicNotationEnv.t list) (loc : Ast.location) =
+ CicNotationEnv.coalesce_env p_names env_list
+ in
+ let gram_of_list s =
+ match magic with
+ | Ast.List0 (_, None) -> Gramext.Slist0 s
+ | Ast.List1 (_, None) -> Gramext.Slist1 s
+ | Ast.List0 (_, Some l) -> Gramext.Slist0sep (s, gram_of_literal l)
+ | Ast.List1 (_, Some l) -> Gramext.Slist1sep (s, gram_of_literal l)
+ | _ -> assert false
+ in
+ [ Env (List.map Env.list_declaration p_names),
+ Gramext.srules
+ [ [ gram_of_list (Gramext.srules [ p_atoms, p_action ]) ],
+ Gramext.action action ] ]
+ | _ -> assert false
+ and aux_variable =
+ function
+ | Ast.NumVar s -> [Binding (s, Env.NumType), gram_number ""]
+ | Ast.TermVar s -> [Binding (s, Env.TermType), gram_term]
+ | Ast.IdentVar s -> [Binding (s, Env.StringType), gram_ident ""]
+ | Ast.Ascription (p, s) -> assert false (* TODO *)
+ | Ast.FreshVar _ -> assert false
+ and inner_pattern p =
+ let p_bindings, p_atoms = List.split (aux p) in
+ let p_names = flatten_opt p_bindings in
+ let action =
+ make_action (fun (env : CicNotationEnv.t) (loc : Ast.location) -> env)
+ p_bindings
+ in
+ p_bindings, p_atoms, p_names, action
+ in
+ aux pattern
+
+let level_of precedence associativity =
+ if precedence < min_precedence || precedence > max_precedence then
+ raise (Level_not_found precedence);
+ let assoc_string =
+ match associativity with
+ | Gramext.NonA -> "N"
+ | Gramext.LeftA -> "L"
+ | Gramext.RightA -> "R"
+ in
+ string_of_int precedence ^ assoc_string
+
+type rule_id = Token.t Gramext.g_symbol list
+
+ (* mapping: rule_id -> owned keywords. (rule_id, string list) Hashtbl.t *)
+let owned_keywords = Hashtbl.create 23
+
+let extend level1_pattern ~precedence ~associativity action =
+ let p_bindings, p_atoms =
+ List.split (extract_term_production level1_pattern)
+ in
+ let level = level_of precedence associativity in
+ let p_names = flatten_opt p_bindings in
+ let _ =
+ Grammar.extend
+ [ Grammar.Entry.obj (term: 'a Grammar.Entry.e),
+ Some (Gramext.Level level),
+ [ None,
+ Some associativity,
+ [ p_atoms,
+ (make_action
+ (fun (env: CicNotationEnv.t) (loc: Ast.location) ->
+ (action env loc))
+ p_bindings) ]]]
+ in
+ let keywords = CicNotationUtil.keywords_of_term level1_pattern in
+ let rule_id = p_atoms in
+ List.iter CicNotationLexer.add_level2_ast_keyword keywords;
+ Hashtbl.add owned_keywords rule_id keywords; (* keywords may be [] *)
+ rule_id
+
+let delete rule_id =
+ let atoms = rule_id in
+ (try
+ let keywords = Hashtbl.find owned_keywords rule_id in
+ List.iter CicNotationLexer.remove_level2_ast_keyword keywords
+ with Not_found -> assert false);
+ Grammar.delete_rule term atoms
+
+(** {2 Grammar} *)
+
+let parse_level1_pattern_ref = ref (fun _ -> assert false)
+let parse_level2_ast_ref = ref (fun _ -> assert false)
+let parse_level2_meta_ref = ref (fun _ -> assert false)
+
+let fold_cluster binder terms ty body =
+ List.fold_right
+ (fun term body -> Ast.Binder (binder, (term, ty), body))
+ terms body (* terms are names: either Ident or FreshVar *)
+
+let fold_exists terms ty body =
+ List.fold_right
+ (fun term body ->
+ let lambda = Ast.Binder (`Lambda, (term, ty), body) in
+ Ast.Appl [ Ast.Symbol ("exists", 0); lambda ])
+ terms body
+
+let fold_binder binder pt_names body =
+ List.fold_right
+ (fun (names, ty) body -> fold_cluster binder names ty body)
+ pt_names body
+
+let return_term loc term = Ast.AttributedTerm (`Loc loc, term)
+
+ (* create empty precedence level for "term" *)
+let _ =
+ let dummy_action =
+ Gramext.action (fun _ ->
+ failwith "internal error, lexer generated a dummy token")
+ in
+ (* Needed since campl4 on "delete_rule" remove the precedence level if it gets
+ * empty after the deletion. The lexer never generate the Stoken below. *)
+ let dummy_prod = [ [ Gramext.Stoken ("DUMMY", "") ], dummy_action ] in
+ let mk_level_list first last =
+ let rec aux acc = function
+ | i when i < first -> acc
+ | i ->
+ aux
+ ((Some (string_of_int i ^ "N"), Some Gramext.NonA, dummy_prod)
+ :: (Some (string_of_int i ^ "L"), Some Gramext.LeftA, dummy_prod)
+ :: (Some (string_of_int i ^ "R"), Some Gramext.RightA, dummy_prod)
+ :: acc)
+ (i - 1)
+ in
+ aux [] last
+ in
+ Grammar.extend
+ [ Grammar.Entry.obj (term: 'a Grammar.Entry.e),
+ None,
+ mk_level_list min_precedence max_precedence ]
+
+(* {{{ Grammar for concrete syntax patterns, notation level 1 *)
+EXTEND
+ GLOBAL: level1_pattern;
+
+ level1_pattern: [ [ p = l1_pattern; EOI -> CicNotationUtil.boxify p ] ];
+ l1_pattern: [ [ p = LIST1 l1_simple_pattern -> p ] ];
+ literal: [
+ [ s = SYMBOL -> `Symbol s
+ | k = QKEYWORD -> `Keyword k
+ | n = NUMBER -> `Number n
+ ]
+ ];
+ sep: [ [ "sep"; sep = literal -> sep ] ];
+(* row_sep: [ [ "rowsep"; sep = literal -> sep ] ];
+ field_sep: [ [ "fieldsep"; sep = literal -> sep ] ]; *)
+ l1_magic_pattern: [
+ [ "list0"; p = l1_simple_pattern; sep = OPT sep -> Ast.List0 (p, sep)
+ | "list1"; p = l1_simple_pattern; sep = OPT sep -> Ast.List1 (p, sep)
+ | "opt"; p = l1_simple_pattern -> Ast.Opt p
+ ]
+ ];
+ l1_pattern_variable: [
+ [ "term"; id = IDENT -> Ast.TermVar id
+ | "number"; id = IDENT -> Ast.NumVar id
+ | "ident"; id = IDENT -> Ast.IdentVar id
+ ]
+ ];
+ l1_simple_pattern:
+ [ "layout" LEFTA
+ [ p1 = SELF; SYMBOL "\\sub"; p2 = SELF ->
+ return_term loc (Ast.Layout (Ast.Sub (p1, p2)))
+ | p1 = SELF; SYMBOL "\\sup"; p2 = SELF ->
+ return_term loc (Ast.Layout (Ast.Sup (p1, p2)))
+ | p1 = SELF; SYMBOL "\\below"; p2 = SELF ->
+ return_term loc (Ast.Layout (Ast.Below (p1, p2)))
+ | p1 = SELF; SYMBOL "\\above"; p2 = SELF ->
+ return_term loc (Ast.Layout (Ast.Above (p1, p2)))
+ | p1 = SELF; SYMBOL "\\over"; p2 = SELF ->
+ return_term loc (Ast.Layout (Ast.Over (p1, p2)))
+ | p1 = SELF; SYMBOL "\\atop"; p2 = SELF ->
+ return_term loc (Ast.Layout (Ast.Atop (p1, p2)))
+(* | "array"; p = SELF; csep = OPT field_sep; rsep = OPT row_sep ->
+ return_term loc (Array (p, csep, rsep)) *)
+ | SYMBOL "\\frac"; p1 = SELF; p2 = SELF ->
+ return_term loc (Ast.Layout (Ast.Frac (p1, p2)))
+ | SYMBOL "\\sqrt"; p = SELF -> return_term loc (Ast.Layout (Ast.Sqrt p))
+ | SYMBOL "\\root"; index = SELF; SYMBOL "\\of"; arg = SELF ->
+ return_term loc (Ast.Layout (Ast.Root (arg, index)))
+ | "hbox"; LPAREN; p = l1_pattern; RPAREN ->
+ return_term loc (Ast.Layout (Ast.Box ((Ast.H, false, false), p)))
+ | "vbox"; LPAREN; p = l1_pattern; RPAREN ->
+ return_term loc (Ast.Layout (Ast.Box ((Ast.V, false, false), p)))
+ | "hvbox"; LPAREN; p = l1_pattern; RPAREN ->
+ return_term loc (Ast.Layout (Ast.Box ((Ast.HV, false, false), p)))
+ | "hovbox"; LPAREN; p = l1_pattern; RPAREN ->
+ return_term loc (Ast.Layout (Ast.Box ((Ast.HOV, false, false), p)))
+ | "break" -> return_term loc (Ast.Layout Ast.Break)
+(* | SYMBOL "\\SPACE" -> return_term loc (Layout Space) *)
+ | LPAREN; p = l1_pattern; RPAREN ->
+ return_term loc (CicNotationUtil.group p)
+ ]
+ | "simple" NONA
+ [ i = IDENT -> return_term loc (Ast.Variable (Ast.TermVar i))
+ | m = l1_magic_pattern -> return_term loc (Ast.Magic m)
+ | v = l1_pattern_variable -> return_term loc (Ast.Variable v)
+ | l = literal -> return_term loc (Ast.Literal l)
+ ]
+ ];
+ END
+(* }}} *)
+
+(* {{{ Grammar for ast magics, notation level 2 *)
+EXTEND
+ GLOBAL: level2_meta;
+ l2_variable: [
+ [ "term"; id = IDENT -> Ast.TermVar id
+ | "number"; id = IDENT -> Ast.NumVar id
+ | "ident"; id = IDENT -> Ast.IdentVar id
+ | "fresh"; id = IDENT -> Ast.FreshVar id
+ | "anonymous" -> Ast.TermVar "_"
+ | id = IDENT -> Ast.TermVar id
+ ]
+ ];
+ l2_magic: [
+ [ "fold"; kind = [ "left" -> `Left | "right" -> `Right ];
+ base = level2_meta; "rec"; id = IDENT; recursive = level2_meta ->
+ Ast.Fold (kind, base, [id], recursive)
+ | "default"; some = level2_meta; none = level2_meta ->
+ Ast.Default (some, none)
+ | "if"; p_test = level2_meta;
+ "then"; p_true = level2_meta;
+ "else"; p_false = level2_meta ->
+ Ast.If (p_test, p_true, p_false)
+ | "fail" -> Ast.Fail
+ ]
+ ];
+ level2_meta: [
+ [ magic = l2_magic -> Ast.Magic magic
+ | var = l2_variable -> Ast.Variable var
+ | blob = UNPARSED_AST ->
+ !parse_level2_ast_ref (Ulexing.from_utf8_string blob)
+ ]
+ ];
+END
+(* }}} *)
+
+(* {{{ Grammar for ast patterns, notation level 2 *)
+EXTEND
+ GLOBAL: level2_ast term let_defs;
+ level2_ast: [ [ p = term -> p ] ];
+ sort: [
+ [ "Prop" -> `Prop
+ | "Set" -> `Set
+ | "Type" -> `Type (CicUniv.fresh ())
+ | "CProp" -> `CProp
+ ]
+ ];
+ explicit_subst: [
+ [ SYMBOL "\\subst"; (* to avoid catching frequent "a [1]" cases *)
+ SYMBOL "[";
+ substs = LIST1 [
+ i = IDENT; SYMBOL <:unicode<Assign>> (* ≔ *); t = term -> (i, t)
+ ] SEP SYMBOL ";";
+ SYMBOL "]" ->
+ substs
+ ]
+ ];
+ meta_subst: [
+ [ s = SYMBOL "_" -> None
+ | p = term -> Some p ]
+ ];
+ meta_substs: [
+ [ SYMBOL "["; substs = LIST0 meta_subst; SYMBOL "]" -> substs ]
+ ];
+ possibly_typed_name: [
+ [ LPAREN; id = single_arg; SYMBOL ":"; typ = term; RPAREN ->
+ id, Some typ
+ | arg = single_arg -> arg, None
+ ]
+ ];
+ match_pattern: [
+ [ id = IDENT -> id, None, []
+ | LPAREN; id = IDENT; vars = LIST1 possibly_typed_name; RPAREN ->
+ id, None, vars
+ ]
+ ];
+ binder: [
+ [ SYMBOL <:unicode<Pi>> (* Π *) -> `Pi
+(* | SYMBOL <:unicode<exists>> |+ ∃ +| -> `Exists *)
+ | SYMBOL <:unicode<forall>> (* ∀ *) -> `Forall
+ | SYMBOL <:unicode<lambda>> (* λ *) -> `Lambda
+ ]
+ ];
+ arg: [
+ [ LPAREN; names = LIST1 IDENT SEP SYMBOL ",";
+ SYMBOL ":"; ty = term; RPAREN ->
+ List.map (fun n -> Ast.Ident (n, None)) names, Some ty
+ | name = IDENT -> [Ast.Ident (name, None)], None
+ | blob = UNPARSED_META ->
+ let meta = !parse_level2_meta_ref (Ulexing.from_utf8_string blob) in
+ match meta with
+ | Ast.Variable (Ast.FreshVar _) -> [meta], None
+ | Ast.Variable (Ast.TermVar "_") -> [Ast.Ident ("_", None)], None
+ | _ -> failwith "Invalid bound name."
+ ]
+ ];
+ single_arg: [
+ [ name = IDENT -> Ast.Ident (name, None)
+ | blob = UNPARSED_META ->
+ let meta = !parse_level2_meta_ref (Ulexing.from_utf8_string blob) in
+ match meta with
+ | Ast.Variable (Ast.FreshVar _)
+ | Ast.Variable (Ast.IdentVar _) -> meta
+ | Ast.Variable (Ast.TermVar "_") -> Ast.Ident ("_", None)
+ | _ -> failwith "Invalid index name."
+ ]
+ ];
+ induction_kind: [
+ [ "rec" -> `Inductive
+ | "corec" -> `CoInductive
+ ]
+ ];
+ let_defs: [
+ [ defs = LIST1 [
+ name = single_arg;
+ args = LIST1 arg;
+ index_name = OPT [ "on"; id = single_arg -> id ];
+ ty = OPT [ SYMBOL ":" ; p = term -> p ];
+ SYMBOL <:unicode<def>> (* ≝ *); body = term ->
+ let body = fold_binder `Lambda args body in
+ let ty =
+ match ty with
+ | None -> None
+ | Some ty -> Some (fold_binder `Pi args ty)
+ in
+ let rec position_of name p = function
+ | [] -> None, p
+ | n :: _ when n = name -> Some p, p
+ | _ :: tl -> position_of name (p + 1) tl
+ in
+ let rec find_arg name n = function
+ | [] ->
+ Ast.fail loc (sprintf "Argument %s not found"
+ (CicNotationPp.pp_term name))
+ | (l,_) :: tl ->
+ (match position_of name 0 l with
+ | None, len -> find_arg name (n + len) tl
+ | Some where, len -> n + where)
+ in
+ let index =
+ match index_name with
+ | None -> 0
+ | Some index_name -> find_arg index_name 0 args
+ in
+ (name, ty), body, index
+ ] SEP "and" ->
+ defs
+ ]
+ ];
+ binder_vars: [
+ [ vars = [
+ l = LIST1 single_arg SEP SYMBOL "," -> l
+ | SYMBOL "_" -> [Ast.Ident ("_", None)] ];
+ typ = OPT [ SYMBOL ":"; t = term -> t ] -> (vars, typ)
+ | LPAREN;
+ vars = [
+ l = LIST1 single_arg SEP SYMBOL "," -> l
+ | SYMBOL "_" -> [Ast.Ident ("_", None)] ];
+ typ = OPT [ SYMBOL ":"; t = term -> t ];
+ RPAREN -> (vars, typ)
+ ]
+ ];
+ term: LEVEL "10N" [ (* let in *)
+ [ "let"; var = possibly_typed_name; SYMBOL <:unicode<def>> (* ≝ *);
+ p1 = term; "in"; p2 = term ->
+ return_term loc (Ast.LetIn (var, p1, p2))
+ | "let"; k = induction_kind; defs = let_defs; "in";
+ body = term ->
+ return_term loc (Ast.LetRec (k, defs, body))
+ ]
+ ];
+ term: LEVEL "20R" (* binder *)
+ [
+ [ b = binder; (vars, typ) = binder_vars; SYMBOL "."; body = term ->
+ return_term loc (fold_cluster b vars typ body)
+ | SYMBOL <:unicode<exists>> (* ∃ *);
+ (vars, typ) = binder_vars; SYMBOL "."; body = term ->
+ return_term loc (fold_exists vars typ body)
+ ]
+ ];
+ term: LEVEL "70L" (* apply *)
+ [
+ [ p1 = term; p2 = term ->
+ let rec aux = function
+ | Ast.Appl (hd :: tl)
+ | Ast.AttributedTerm (_, Ast.Appl (hd :: tl)) ->
+ aux hd @ tl
+ | term -> [term]
+ in
+ return_term loc (Ast.Appl (aux p1 @ [p2]))
+ ]
+ ];
+ term: LEVEL "90N" (* simple *)
+ [
+ [ id = IDENT -> return_term loc (Ast.Ident (id, None))
+ | id = IDENT; s = explicit_subst ->
+ return_term loc (Ast.Ident (id, Some s))
+ | s = CSYMBOL -> return_term loc (Ast.Symbol (s, 0))
+ | u = URI -> return_term loc (Ast.Uri (u, None))
+ | n = NUMBER -> return_term loc (Ast.Num (n, 0))
+ | IMPLICIT -> return_term loc (Ast.Implicit)
+ | PLACEHOLDER -> return_term loc Ast.UserInput
+ | m = META -> return_term loc (Ast.Meta (int_of_string m, []))
+ | m = META; s = meta_substs ->
+ return_term loc (Ast.Meta (int_of_string m, s))
+ | s = sort -> return_term loc (Ast.Sort s)
+ | "match"; t = term;
+ indty_ident = OPT [ "in"; id = IDENT -> id, None ];
+ outtyp = OPT [ "return"; ty = term -> ty ];
+ "with"; SYMBOL "[";
+ patterns = LIST0 [
+ lhs = match_pattern; SYMBOL <:unicode<Rightarrow>> (* ⇒ *);
+ rhs = term ->
+ lhs, rhs
+ ] SEP SYMBOL "|";
+ SYMBOL "]" ->
+ return_term loc (Ast.Case (t, indty_ident, outtyp, patterns))
+ | LPAREN; p1 = term; SYMBOL ":"; p2 = term; RPAREN ->
+ return_term loc (Ast.Cast (p1, p2))
+ | LPAREN; p = term; RPAREN -> p
+ | blob = UNPARSED_META ->
+ !parse_level2_meta_ref (Ulexing.from_utf8_string blob)
+ ]
+ ];
+END
+(* }}} *)
+
+(** {2 API implementation} *)
+
+let exc_located_wrapper f =
+ try
+ f ()
+ with
+ | Stdpp.Exc_located (floc, Stream.Error msg) ->
+ raise (HExtlib.Localized (floc, Parse_error msg))
+ | Stdpp.Exc_located (floc, exn) ->
+ raise (HExtlib.Localized (floc, (Parse_error (Printexc.to_string exn))))
+
+let parse_level1_pattern lexbuf =
+ exc_located_wrapper
+ (fun () -> Grammar.Entry.parse level1_pattern (Obj.magic lexbuf))
+
+let parse_level2_ast lexbuf =
+ exc_located_wrapper
+ (fun () -> Grammar.Entry.parse level2_ast (Obj.magic lexbuf))
+
+let parse_level2_meta lexbuf =
+ exc_located_wrapper
+ (fun () -> Grammar.Entry.parse level2_meta (Obj.magic lexbuf))
+
+let _ =
+ parse_level1_pattern_ref := parse_level1_pattern;
+ parse_level2_ast_ref := parse_level2_ast;
+ parse_level2_meta_ref := parse_level2_meta
+
+(** {2 Debugging} *)
+
+let print_l2_pattern () =
+ Grammar.print_entry Format.std_formatter (Grammar.Entry.obj term);
+ Format.pp_print_flush Format.std_formatter ();
+ flush stdout
+
+(* vim:set encoding=utf8 foldmethod=marker: *)
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+exception Parse_error of string
+exception Level_not_found of int
+
+(** {2 Parsing functions} *)
+
+ (** concrete syntax pattern: notation level 1 *)
+val parse_level1_pattern: Ulexing.lexbuf -> CicNotationPt.term
+
+ (** AST pattern: notation level 2 *)
+val parse_level2_ast: Ulexing.lexbuf -> CicNotationPt.term
+val parse_level2_meta: Ulexing.lexbuf -> CicNotationPt.term
+
+(** {2 Grammar extension} *)
+
+type rule_id
+
+val extend:
+ CicNotationPt.term -> (* level 1 pattern *)
+ precedence:int ->
+ associativity:Gramext.g_assoc ->
+ (CicNotationEnv.t -> CicNotationPt.location -> CicNotationPt.term) ->
+ rule_id
+
+val delete: rule_id -> unit
+
+(** {2 Grammar entries}
+ * needed by grafite parser *)
+
+val level2_ast_grammar: Grammar.g
+
+val term : CicNotationPt.term Grammar.Entry.e
+
+val let_defs :
+ (CicNotationPt.capture_variable * CicNotationPt.term * int) list
+ Grammar.Entry.e
+
+(** {2 Debugging} *)
+
+ (** print "level2_pattern" entry on stdout, flushing afterwards *)
+val print_l2_pattern: unit -> unit
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+module Ast = CicNotationPt
+module Mpres = Mpresentation
+
+type mathml_markup = boxml_markup Mpres.mpres
+and boxml_markup = mathml_markup Box.box
+
+type markup = mathml_markup
+
+let atop_attributes = [None, "linethickness", "0pt"]
+
+let to_unicode = Utf8Macro.unicode_of_tex
+
+let rec make_attributes l1 = function
+ | [] -> []
+ | hd :: tl ->
+ (match hd with
+ | None -> make_attributes (List.tl l1) tl
+ | Some s ->
+ let p,n = List.hd l1 in
+ (p,n,s) :: make_attributes (List.tl l1) tl)
+
+let box_of_mpres =
+ function
+ | Mpresentation.Mobject (attrs, box) ->
+ assert (attrs = []);
+ box
+ | mpres -> Box.Object ([], mpres)
+
+let mpres_of_box =
+ function
+ | Box.Object (attrs, mpres) ->
+ assert (attrs = []);
+ mpres
+ | box -> Mpresentation.Mobject ([], box)
+
+let rec genuine_math =
+ function
+ | Mpresentation.Mobject ([], obj) -> not (genuine_box obj)
+ | _ -> true
+and genuine_box =
+ function
+ | Box.Object ([], mpres) -> not (genuine_math mpres)
+ | _ -> true
+
+let rec eligible_math =
+ function
+ | Mpresentation.Mobject ([], Box.Object ([], mpres)) -> eligible_math mpres
+ | Mpresentation.Mobject ([], _) -> false
+ | _ -> true
+
+let rec promote_to_math =
+ function
+ | Mpresentation.Mobject ([], Box.Object ([], mpres)) -> promote_to_math mpres
+ | math -> math
+
+let small_skip =
+ Mpresentation.Mspace (RenderingAttrs.small_skip_attributes `MathML)
+
+let rec add_mpres_attributes new_attr = function
+ | Mpresentation.Mobject (attr, box) ->
+ Mpresentation.Mobject (attr, add_box_attributes new_attr box)
+ | mpres ->
+ Mpresentation.set_attr (new_attr @ Mpresentation.get_attr mpres) mpres
+and add_box_attributes new_attr = function
+ | Box.Object (attr, mpres) ->
+ Box.Object (attr, add_mpres_attributes new_attr mpres)
+ | box -> Box.set_attr (new_attr @ Box.get_attr box) box
+
+let box_of mathonly spec attrs children =
+ match children with
+ | [t] -> add_mpres_attributes attrs t
+ | _ ->
+ let kind, spacing, indent = spec in
+ let dress children =
+ if spacing then
+ CicNotationUtil.dress small_skip children
+ else
+ children
+ in
+ if mathonly then Mpresentation.Mrow (attrs, dress children)
+ else
+ let attrs' =
+ (if spacing then RenderingAttrs.spacing_attributes `BoxML else [])
+ @ (if indent then RenderingAttrs.indent_attributes `BoxML else [])
+ @ attrs
+ in
+ match kind with
+ | Ast.H ->
+ if List.for_all eligible_math children then
+ Mpresentation.Mrow (attrs',
+ dress (List.map promote_to_math children))
+ else
+ mpres_of_box (Box.H (attrs',
+ List.map box_of_mpres children))
+(* | Ast.H when List.for_all genuine_math children ->
+ Mpresentation.Mrow (attrs', dress children) *)
+ | Ast.V ->
+ mpres_of_box (Box.V (attrs',
+ List.map box_of_mpres children))
+ | Ast.HV ->
+ mpres_of_box (Box.HV (attrs',
+ List.map box_of_mpres children))
+ | Ast.HOV ->
+ mpres_of_box (Box.HOV (attrs',
+ List.map box_of_mpres children))
+
+let open_paren = Mpresentation.Mo ([], "(")
+let closed_paren = Mpresentation.Mo ([], ")")
+let open_brace = Mpresentation.Mo ([], "{")
+let closed_brace = Mpresentation.Mo ([], "}")
+let hidden_substs = Mpresentation.Mtext ([], "{...}")
+let open_box_paren = Box.Text ([], "(")
+let closed_box_paren = Box.Text ([], ")")
+let semicolon = Mpresentation.Mo ([], ";")
+let toggle_action children =
+ Mpresentation.Maction ([None, "actiontype", "toggle"], children)
+
+type child_pos = [ `Left | `Right | `Inner ]
+
+let pp_assoc =
+ function
+ | Gramext.LeftA -> "LeftA"
+ | Gramext.RightA -> "RightA"
+ | Gramext.NonA -> "NonA"
+
+let is_atomic t =
+ let rec aux_mpres = function
+ | Mpres.Mi _
+ | Mpres.Mo _
+ | Mpres.Mn _
+ | Mpres.Ms _
+ | Mpres.Mtext _
+ | Mpres.Mspace _ -> true
+ | Mpres.Mobject (_, box) -> aux_box box
+ | Mpres.Maction (_, [mpres])
+ | Mpres.Mrow (_, [mpres]) -> aux_mpres mpres
+ | _ -> false
+ and aux_box = function
+ | Box.Space _
+ | Box.Ink _
+ | Box.Text _ -> true
+ | Box.Object (_, mpres) -> aux_mpres mpres
+ | Box.H (_, [box])
+ | Box.V (_, [box])
+ | Box.HV (_, [box])
+ | Box.HOV (_, [box])
+ | Box.Action (_, [box]) -> aux_box box
+ | _ -> false
+ in
+ aux_mpres t
+
+let add_parens child_prec child_assoc child_pos curr_prec t =
+ if is_atomic t then t
+ else if child_prec >= 0
+ && (child_prec < curr_prec
+ || (child_prec = curr_prec &&
+ child_assoc = Gramext.LeftA &&
+ child_pos = `Right)
+ || (child_prec = curr_prec &&
+ child_assoc = Gramext.RightA &&
+ child_pos = `Left))
+ then (* parens should be added *)
+(* (prerr_endline "adding parens";
+ prerr_endline (Printf.sprintf "child_prec = %d\nchild_assoc = %s\nchild_pos = %s\ncurr_prec= %d"
+ child_prec (pp_assoc child_assoc) (CicNotationPp.pp_pos
+ child_pos) curr_prec); *)
+ match t with
+ | Mpresentation.Mobject (_, box) ->
+ mpres_of_box (Box.H ([], [ open_box_paren; box; closed_box_paren ]))
+ | mpres -> Mpresentation.Mrow ([], [open_paren; t; closed_paren])
+ else
+ t
+
+let render ids_to_uris =
+ let module A = Ast in
+ let module P = Mpresentation in
+ let use_unicode = true in
+ let lookup_uri id =
+ (try
+ let uri = Hashtbl.find ids_to_uris id in
+ Some (UriManager.string_of_uri uri)
+ with Not_found -> None)
+ in
+ let make_href xmlattrs xref =
+ let xref_uris =
+ List.fold_right
+ (fun xref uris ->
+ match lookup_uri xref with
+ | None -> uris
+ | Some uri -> uri :: uris)
+ !xref []
+ in
+ let xmlattrs_uris, xmlattrs =
+ let xref_attrs, other_attrs =
+ List.partition
+ (function Some "xlink", "href", _ -> true | _ -> false)
+ xmlattrs
+ in
+ List.map (fun (_, _, uri) -> uri) xref_attrs,
+ other_attrs
+ in
+ let uris =
+ match xmlattrs_uris @ xref_uris with
+ | [] -> None
+ | uris ->
+ Some (String.concat " "
+ (HExtlib.list_uniq (List.sort String.compare uris)))
+ in
+ let xrefs =
+ match !xref with [] -> None | xrefs -> Some (String.concat " " xrefs)
+ in
+ xref := [];
+ xmlattrs
+ @ make_attributes [Some "helm", "xref"; Some "xlink", "href"]
+ [xrefs; uris]
+ in
+ let make_xref xref =
+ let xrefs =
+ match !xref with [] -> None | xrefs -> Some (String.concat " " xrefs)
+ in
+ xref := [];
+ make_attributes [Some "helm","xref"] [xrefs]
+ in
+ (* when mathonly is true no boxes should be generated, only mrows *)
+ (* "xref" is *)
+ let rec aux xmlattrs mathonly xref pos prec t =
+ match t with
+ | A.AttributedTerm _ ->
+ aux_attributes xmlattrs mathonly xref pos prec t
+ | A.Num (literal, _) ->
+ let attrs =
+ (RenderingAttrs.number_attributes `MathML)
+ @ make_href xmlattrs xref
+ in
+ Mpres.Mn (attrs, literal)
+ | A.Symbol (literal, _) ->
+ let attrs =
+ (RenderingAttrs.symbol_attributes `MathML)
+ @ make_href xmlattrs xref
+ in
+ Mpres.Mo (attrs, to_unicode literal)
+ | A.Ident (literal, subst)
+ | A.Uri (literal, subst) ->
+ let attrs =
+ (RenderingAttrs.ident_attributes `MathML)
+ @ make_href xmlattrs xref
+ in
+ let name = Mpres.Mi (attrs, to_unicode literal) in
+ (match subst with
+ | Some []
+ | None -> name
+ | Some substs ->
+ let substs' =
+ box_of mathonly (A.H, false, false) []
+ (open_brace
+ :: (CicNotationUtil.dress semicolon
+ (List.map
+ (fun (name, t) ->
+ box_of mathonly (A.H, false, false) [] [
+ Mpres.Mi ([], name);
+ Mpres.Mo ([], to_unicode "\\def");
+ aux [] mathonly xref pos prec t ])
+ substs))
+ @ [ closed_brace ])
+ in
+ let substs_maction = toggle_action [ hidden_substs; substs' ] in
+ box_of mathonly (A.H, false, false) [] [ name; substs_maction ])
+ | A.Literal l -> aux_literal xmlattrs xref prec l
+ | A.UserInput -> Mpres.Mtext ([], "%")
+ | A.Layout l -> aux_layout mathonly xref pos prec l
+ | A.Magic _
+ | A.Variable _ -> assert false (* should have been instantiated *)
+ | t ->
+ prerr_endline ("unexpected ast: " ^ CicNotationPp.pp_term t);
+ assert false
+ and aux_attributes xmlattrs mathonly xref pos prec t =
+ let reset = ref false in
+ let new_level = ref None in
+ let new_xref = ref [] in
+ let new_xmlattrs = ref [] in
+ let new_pos = ref pos in
+ let reinit = ref false in
+ let rec aux_attribute =
+ function
+ | A.AttributedTerm (attr, t) ->
+ (match attr with
+ | `Loc _
+ | `Raw _ -> ()
+ | `Level (-1, _) -> reset := true
+ | `Level (child_prec, child_assoc) ->
+ new_level := Some (child_prec, child_assoc)
+ | `IdRef xref -> new_xref := xref :: !new_xref
+ | `ChildPos pos -> new_pos := pos
+ | `XmlAttrs attrs -> new_xmlattrs := attrs @ !new_xmlattrs);
+ aux_attribute t
+ | t ->
+ (match !new_level with
+ | None -> aux !new_xmlattrs mathonly new_xref !new_pos prec t
+ | Some (child_prec, child_assoc) ->
+ let t' =
+ aux !new_xmlattrs mathonly new_xref !new_pos child_prec t
+ in
+ if !reset then t'
+ else add_parens child_prec child_assoc !new_pos prec t')
+ in
+ aux_attribute t
+ and aux_literal xmlattrs xref prec l =
+ let attrs = make_href xmlattrs xref in
+ (match l with
+ | `Symbol s -> Mpres.Mo (attrs, to_unicode s)
+ | `Keyword s -> Mpres.Mo (attrs, to_unicode s)
+ | `Number s -> Mpres.Mn (attrs, to_unicode s))
+ and aux_layout mathonly xref pos prec l =
+ let attrs = make_xref xref in
+ let invoke' t = aux [] true (ref []) pos prec t in
+ (* use the one below to reset precedence and associativity *)
+ let invoke_reinit t = aux [] mathonly xref `Inner ~-1 t in
+ match l with
+ | A.Sub (t1, t2) -> Mpres.Msub (attrs, invoke' t1, invoke_reinit t2)
+ | A.Sup (t1, t2) -> Mpres.Msup (attrs, invoke' t1, invoke_reinit t2)
+ | A.Below (t1, t2) -> Mpres.Munder (attrs, invoke' t1, invoke_reinit t2)
+ | A.Above (t1, t2) -> Mpres.Mover (attrs, invoke' t1, invoke_reinit t2)
+ | A.Frac (t1, t2)
+ | A.Over (t1, t2) ->
+ Mpres.Mfrac (attrs, invoke_reinit t1, invoke_reinit t2)
+ | A.Atop (t1, t2) ->
+ Mpres.Mfrac (atop_attributes @ attrs, invoke_reinit t1,
+ invoke_reinit t2)
+ | A.Sqrt t -> Mpres.Msqrt (attrs, invoke_reinit t)
+ | A.Root (t1, t2) ->
+ Mpres.Mroot (attrs, invoke_reinit t1, invoke_reinit t2)
+ | A.Box ((_, spacing, _) as kind, terms) ->
+ let children =
+ aux_children mathonly spacing xref pos prec
+ (CicNotationUtil.ungroup terms)
+ in
+ box_of mathonly kind attrs children
+ | A.Group terms ->
+ let children =
+ aux_children mathonly false xref pos prec
+ (CicNotationUtil.ungroup terms)
+ in
+ box_of mathonly (A.H, false, false) attrs children
+ | A.Break -> assert false (* TODO? *)
+ and aux_children mathonly spacing xref pos prec terms =
+ let find_clusters =
+ let rec aux_list first clusters acc =
+ function
+ [] when acc = [] -> List.rev clusters
+ | [] -> aux_list first (List.rev acc :: clusters) [] []
+ | (A.Layout A.Break) :: tl when acc = [] ->
+ aux_list first clusters [] tl
+ | (A.Layout A.Break) :: tl ->
+ aux_list first (List.rev acc :: clusters) [] tl
+ | [hd] ->
+(* let pos' =
+ if first then
+ pos
+ else
+ match pos with
+ `None -> `Right
+ | `Inner -> `Inner
+ | `Right -> `Right
+ | `Left -> `Inner
+ in *)
+ aux_list false clusters
+ (aux [] mathonly xref pos prec hd :: acc) []
+ | hd :: tl ->
+(* let pos' =
+ match pos, first with
+ `None, true -> `Left
+ | `None, false -> `Inner
+ | `Left, true -> `Left
+ | `Left, false -> `Inner
+ | `Right, _ -> `Inner
+ | `Inner, _ -> `Inner
+ in *)
+ aux_list false clusters
+ (aux [] mathonly xref pos prec hd :: acc) tl
+ in
+ aux_list true [] []
+ in
+ let boxify_pres =
+ function
+ [t] -> t
+ | tl -> box_of mathonly (A.H, spacing, false) [] tl
+ in
+ List.map boxify_pres (find_clusters terms)
+ in
+ aux [] false (ref []) `Inner ~-1
+
+let rec print_box (t: boxml_markup) =
+ Box.box2xml print_mpres t
+and print_mpres (t: mathml_markup) =
+ Mpresentation.print_mpres print_box t
+
+let print_xml = print_mpres
+
+(* let render_to_boxml id_to_uri t =
+ let xml_stream = print_box (box_of_mpres (render id_to_uri t)) in
+ Xml.add_xml_declaration xml_stream *)
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+type mathml_markup = boxml_markup Mpresentation.mpres
+and boxml_markup = mathml_markup Box.box
+
+type markup = mathml_markup
+
+(** {2 Markup conversions} *)
+
+val mpres_of_box: boxml_markup -> mathml_markup
+val box_of_mpres: mathml_markup -> boxml_markup
+
+(** {2 Rendering} *)
+
+(** level 1 -> level 0
+ * @param ids_to_uris mapping id -> uri for hyperlinking *)
+val render: (Cic.id, UriManager.uri) Hashtbl.t -> CicNotationPt.term -> markup
+
+(** level 0 -> xml stream *)
+val print_xml: markup -> Xml.token Stream.t
+
+(* |+* level 1 -> xml stream
+ * @param ids_to_uris +|
+val render_to_boxml:
+ (Cic.id, string) Hashtbl.t -> CicNotationPt.term -> Xml.token Stream.t *)
+
+val print_box: boxml_markup -> Xml.token Stream.t
+val print_mpres: mathml_markup -> Xml.token Stream.t
+
--- /dev/null
+(* Copyright (C) 2003-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(***************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Andrea Asperti <asperti@cs.unibo.it> *)
+(* 17/06/2003 *)
+(* *)
+(***************************************************************************)
+
+module P = Mpresentation
+module B = Box
+module Con = Content
+
+let p_mtr a b = Mpresentation.Mtr(a,b)
+let p_mtd a b = Mpresentation.Mtd(a,b)
+let p_mtable a b = Mpresentation.Mtable(a,b)
+let p_mtext a b = Mpresentation.Mtext(a,b)
+let p_mi a b = Mpresentation.Mi(a,b)
+let p_mo a b = Mpresentation.Mo(a,b)
+let p_mrow a b = Mpresentation.Mrow(a,b)
+let p_mphantom a b = Mpresentation.Mphantom(a,b)
+
+let rec split n l =
+ if n = 0 then [],l
+ else let l1,l2 =
+ split (n-1) (List.tl l) in
+ (List.hd l)::l1,l2
+
+let get_xref = function
+ | `Declaration d
+ | `Hypothesis d -> d.Con.dec_id
+ | `Proof p -> p.Con.proof_id
+ | `Definition d -> d.Con.def_id
+ | `Joint jo -> jo.Con.joint_id
+
+let hv_attrs =
+ RenderingAttrs.spacing_attributes `BoxML
+ @ RenderingAttrs.indent_attributes `BoxML
+
+let make_row items concl =
+ B.b_hv hv_attrs (items @ [ concl ])
+(* match concl with
+ B.V _ -> |+ big! +|
+ B.b_v attrs [B.b_h [] items; B.b_indent concl]
+ | _ -> |+ small +|
+ B.b_h attrs (items@[B.b_space; concl]) *)
+
+let make_concl ?(attrs=[]) verb concl =
+ B.b_hv (hv_attrs @ attrs) [ B.b_kw verb; concl ]
+(* match concl with
+ B.V _ -> |+ big! +|
+ B.b_v attrs [ B.b_kw verb; B.b_indent concl]
+ | _ -> |+ small +|
+ B.b_h attrs [ B.b_kw verb; B.b_space; concl ] *)
+
+let make_args_for_apply term2pres args =
+ let make_arg_for_apply is_first arg row =
+ let res =
+ match arg with
+ Con.Aux n -> assert false
+ | Con.Premise prem ->
+ let name =
+ (match prem.Con.premise_binder with
+ None -> "previous"
+ | Some s -> s) in
+ (B.b_object (P.Mi ([], name)))::row
+ | Con.Lemma lemma ->
+ let lemma_attrs = [
+ Some "helm", "xref", lemma.Con.lemma_id;
+ Some "xlink", "href", lemma.Con.lemma_uri ]
+ in
+ (B.b_object (P.Mi(lemma_attrs,lemma.Con.lemma_name)))::row
+ | Con.Term t ->
+ if is_first then
+ (term2pres t)::row
+ else (B.b_object (P.Mi([],"_")))::row
+ | Con.ArgProof _
+ | Con.ArgMethod _ ->
+ (B.b_object (P.Mi([],"_")))::row
+ in
+ if is_first then res else B.skip::res
+ in
+ match args with
+ hd::tl ->
+ make_arg_for_apply true hd
+ (List.fold_right (make_arg_for_apply false) tl [])
+ | _ -> assert false
+
+let get_name = function
+ | Some s -> s
+ | None -> "_"
+
+let add_xref id = function
+ | B.Text (attrs, t) -> B.Text (((Some "helm", "xref", id) :: attrs), t)
+ | _ -> assert false (* TODO, add_xref is meaningful for all boxes *)
+
+let rec justification term2pres p =
+ if ((p.Con.proof_conclude.Con.conclude_method = "Exact") or
+ ((p.Con.proof_context = []) &
+ (p.Con.proof_apply_context = []) &
+ (p.Con.proof_conclude.Con.conclude_method = "Apply"))) then
+ let pres_args =
+ make_args_for_apply term2pres p.Con.proof_conclude.Con.conclude_args in
+ B.H([],
+ (B.b_kw "by")::B.b_space::
+ B.Text([],"(")::pres_args@[B.Text([],")")])
+ else proof2pres term2pres p
+
+and proof2pres term2pres p =
+ let rec proof2pres p =
+ let indent =
+ let is_decl e =
+ (match e with
+ `Declaration _
+ | `Hypothesis _ -> true
+ | _ -> false) in
+ ((List.filter is_decl p.Con.proof_context) != []) in
+ let omit_conclusion = (not indent) && (p.Con.proof_context != []) in
+ let concl =
+ (match p.Con.proof_conclude.Con.conclude_conclusion with
+ None -> None
+ | Some t -> Some (term2pres t)) in
+ let body =
+ let presconclude =
+ conclude2pres p.Con.proof_conclude indent omit_conclusion in
+ let presacontext =
+ acontext2pres p.Con.proof_apply_context presconclude indent in
+ context2pres p.Con.proof_context presacontext in
+ match p.Con.proof_name with
+ None -> body
+ | Some name ->
+ let action =
+ match concl with
+ None -> body
+ | Some ac ->
+ B.Action
+ ([None,"type","toggle"],
+ [(make_concl ~attrs:[Some "helm", "xref", p.Con.proof_id]
+ "proof of" ac); body])
+ in
+ B.V ([],
+ [B.Text ([],"(" ^ name ^ ")");
+ B.indent action])
+
+ and context2pres c continuation =
+ (* we generate a subtable for each context element, for selection
+ purposes
+ The table generated by the head-element does not have an xref;
+ the whole context-proof is already selectable *)
+ match c with
+ [] -> continuation
+ | hd::tl ->
+ let continuation' =
+ List.fold_right
+ (fun ce continuation ->
+ let xref = get_xref ce in
+ B.V([Some "helm", "xref", xref ],
+ [B.H([Some "helm", "xref", "ce_"^xref],
+ [ce2pres_in_proof_context_element ce]);
+ continuation])) tl continuation in
+ let hd_xref= get_xref hd in
+ B.V([],
+ [B.H([Some "helm", "xref", "ce_"^hd_xref],
+ [ce2pres_in_proof_context_element hd]);
+ continuation'])
+
+ and ce2pres_in_joint_context_element = function
+ | `Inductive _ -> assert false (* TODO *)
+ | (`Declaration _) as x -> ce2pres x
+ | (`Hypothesis _) as x -> ce2pres x
+ | (`Proof _) as x -> ce2pres x
+ | (`Definition _) as x -> ce2pres x
+
+ and ce2pres_in_proof_context_element = function
+ | `Joint ho ->
+ B.H ([],(List.map ce2pres_in_joint_context_element ho.Content.joint_defs))
+ | (`Declaration _) as x -> ce2pres x
+ | (`Hypothesis _) as x -> ce2pres x
+ | (`Proof _) as x -> ce2pres x
+ | (`Definition _) as x -> ce2pres x
+
+ and ce2pres =
+ function
+ `Declaration d ->
+ (match d.Con.dec_name with
+ Some s ->
+ let ty = term2pres d.Con.dec_type in
+ B.H ([],
+ [(B.b_kw "Assume");
+ B.b_space;
+ B.Object ([], P.Mi([],s));
+ B.Text([],":");
+ ty])
+ | None ->
+ prerr_endline "NO NAME!!"; assert false)
+ | `Hypothesis h ->
+ (match h.Con.dec_name with
+ Some s ->
+ let ty = term2pres h.Con.dec_type in
+ B.H ([],
+ [(B.b_kw "Suppose");
+ B.b_space;
+ B.Text([],"(");
+ B.Object ([], P.Mi ([],s));
+ B.Text([],")");
+ B.b_space;
+ ty])
+ | None ->
+ prerr_endline "NO NAME!!"; assert false)
+ | `Proof p ->
+ proof2pres p
+ | `Definition d ->
+ (match d.Con.def_name with
+ Some s ->
+ let term = term2pres d.Con.def_term in
+ B.H ([],
+ [ B.b_kw "Let"; B.b_space;
+ B.Object ([], P.Mi([],s));
+ B.Text([]," = ");
+ term])
+ | None ->
+ prerr_endline "NO NAME!!"; assert false)
+
+ and acontext2pres ac continuation indent =
+ List.fold_right
+ (fun p continuation ->
+ let hd =
+ if indent then
+ B.indent (proof2pres p)
+ else
+ proof2pres p in
+ B.V([Some "helm","xref",p.Con.proof_id],
+ [B.H([Some "helm","xref","ace_"^p.Con.proof_id],[hd]);
+ continuation])) ac continuation
+
+ and conclude2pres conclude indent omit_conclusion =
+ let tconclude_body =
+ match conclude.Con.conclude_conclusion with
+ Some t when
+ not omit_conclusion or
+ (* CSC: I ignore the omit_conclusion flag in this case. *)
+ (* CSC: Is this the correct behaviour? In the stylesheets *)
+ (* CSC: we simply generated nothing (i.e. the output type *)
+ (* CSC: of the function should become an option. *)
+ conclude.Con.conclude_method = "BU_Conversion" ->
+ let concl = (term2pres t) in
+ if conclude.Con.conclude_method = "BU_Conversion" then
+ make_concl "that is equivalent to" concl
+ else if conclude.Con.conclude_method = "FalseInd" then
+ (* false ind is in charge to add the conclusion *)
+ falseind conclude
+ else
+ let conclude_body = conclude_aux conclude in
+ let ann_concl =
+ if conclude.Con.conclude_method = "TD_Conversion" then
+ make_concl "that is equivalent to" concl
+ else make_concl "we conclude" concl in
+ B.V ([], [conclude_body; ann_concl])
+ | _ -> conclude_aux conclude in
+ if indent then
+ B.indent (B.H ([Some "helm", "xref", conclude.Con.conclude_id],
+ [tconclude_body]))
+ else
+ B.H ([Some "helm", "xref", conclude.Con.conclude_id],[tconclude_body])
+
+ and conclude_aux conclude =
+ if conclude.Con.conclude_method = "TD_Conversion" then
+ let expected =
+ (match conclude.Con.conclude_conclusion with
+ None -> B.Text([],"NO EXPECTED!!!")
+ | Some c -> term2pres c) in
+ let subproof =
+ (match conclude.Con.conclude_args with
+ [Con.ArgProof p] -> p
+ | _ -> assert false) in
+ let synth =
+ (match subproof.Con.proof_conclude.Con.conclude_conclusion with
+ None -> B.Text([],"NO SYNTH!!!")
+ | Some c -> (term2pres c)) in
+ B.V
+ ([],
+ [make_concl "we must prove" expected;
+ make_concl "or equivalently" synth;
+ proof2pres subproof])
+ else if conclude.Con.conclude_method = "BU_Conversion" then
+ assert false
+ else if conclude.Con.conclude_method = "Exact" then
+ let arg =
+ (match conclude.Con.conclude_args with
+ [Con.Term t] -> term2pres t
+ | [Con.Premise p] ->
+ (match p.Con.premise_binder with
+ | None -> assert false; (* unnamed hypothesis ??? *)
+ | Some s -> B.Text([],s))
+ | err -> assert false) in
+ (match conclude.Con.conclude_conclusion with
+ None ->
+ B.b_h [] [B.b_kw "Consider"; B.b_space; arg]
+ | Some c -> let conclusion = term2pres c in
+ make_row
+ [arg; B.b_space; B.b_kw "proves"]
+ conclusion
+ )
+ else if conclude.Con.conclude_method = "Intros+LetTac" then
+ (match conclude.Con.conclude_args with
+ [Con.ArgProof p] -> proof2pres p
+ | _ -> assert false)
+(* OLD CODE
+ let conclusion =
+ (match conclude.Con.conclude_conclusion with
+ None -> B.Text([],"NO Conclusion!!!")
+ | Some c -> term2pres c) in
+ (match conclude.Con.conclude_args with
+ [Con.ArgProof p] ->
+ B.V
+ ([None,"align","baseline 1"; None,"equalrows","false";
+ None,"columnalign","left"],
+ [B.H([],[B.Object([],proof2pres p)]);
+ B.H([],[B.Object([],
+ (make_concl "we proved 1" conclusion))])]);
+ | _ -> assert false)
+*)
+ else if (conclude.Con.conclude_method = "Case") then
+ case conclude
+ else if (conclude.Con.conclude_method = "ByInduction") then
+ byinduction conclude
+ else if (conclude.Con.conclude_method = "Exists") then
+ exists conclude
+ else if (conclude.Con.conclude_method = "AndInd") then
+ andind conclude
+ else if (conclude.Con.conclude_method = "FalseInd") then
+ falseind conclude
+ else if (conclude.Con.conclude_method = "Rewrite") then
+ let justif =
+ (match (List.nth conclude.Con.conclude_args 6) with
+ Con.ArgProof p -> justification term2pres p
+ | _ -> assert false) in
+ let term1 =
+ (match List.nth conclude.Con.conclude_args 2 with
+ Con.Term t -> term2pres t
+ | _ -> assert false) in
+ let term2 =
+ (match List.nth conclude.Con.conclude_args 5 with
+ Con.Term t -> term2pres t
+ | _ -> assert false) in
+ B.V ([],
+ [B.H ([],[
+ (B.b_kw "rewrite");
+ B.b_space; term1;
+ B.b_space; (B.b_kw "with");
+ B.b_space; term2;
+ B.indent justif])])
+ else if conclude.Con.conclude_method = "Apply" then
+ let pres_args =
+ make_args_for_apply term2pres conclude.Con.conclude_args in
+ B.H([],
+ (B.b_kw "by")::
+ B.b_space::
+ B.Text([],"(")::pres_args@[B.Text([],")")])
+ else
+ B.V ([], [
+ B.b_kw ("Apply method" ^ conclude.Con.conclude_method ^ " to");
+ (B.indent (B.V ([], args2pres conclude.Con.conclude_args)))])
+
+ and args2pres l = List.map arg2pres l
+
+ and arg2pres =
+ function
+ Con.Aux n -> B.b_kw ("aux " ^ n)
+ | Con.Premise prem -> B.b_kw "premise"
+ | Con.Lemma lemma -> B.b_kw "lemma"
+ | Con.Term t -> term2pres t
+ | Con.ArgProof p -> proof2pres p
+ | Con.ArgMethod s -> B.b_kw "method"
+
+ and case conclude =
+ let proof_conclusion =
+ (match conclude.Con.conclude_conclusion with
+ None -> B.b_kw "No conclusion???"
+ | Some t -> term2pres t) in
+ let arg,args_for_cases =
+ (match conclude.Con.conclude_args with
+ Con.Aux(_)::Con.Aux(_)::Con.Term(_)::arg::tl ->
+ arg,tl
+ | _ -> assert false) in
+ let case_on =
+ let case_arg =
+ (match arg with
+ Con.Aux n -> B.b_kw "an aux???"
+ | Con.Premise prem ->
+ (match prem.Con.premise_binder with
+ None -> B.b_kw "the previous result"
+ | Some n -> B.Object ([], P.Mi([],n)))
+ | Con.Lemma lemma -> B.Object ([], P.Mi([],lemma.Con.lemma_name))
+ | Con.Term t ->
+ term2pres t
+ | Con.ArgProof p -> B.b_kw "a proof???"
+ | Con.ArgMethod s -> B.b_kw "a method???")
+ in
+ (make_concl "we proceed by cases on" case_arg) in
+ let to_prove =
+ (make_concl "to prove" proof_conclusion) in
+ B.V ([], case_on::to_prove::(make_cases args_for_cases))
+
+ and byinduction conclude =
+ let proof_conclusion =
+ (match conclude.Con.conclude_conclusion with
+ None -> B.b_kw "No conclusion???"
+ | Some t -> term2pres t) in
+ let inductive_arg,args_for_cases =
+ (match conclude.Con.conclude_args with
+ Con.Aux(n)::_::tl ->
+ let l1,l2 = split (int_of_string n) tl in
+ let last_pos = (List.length l2)-1 in
+ List.nth l2 last_pos,l1
+ | _ -> assert false) in
+ let induction_on =
+ let arg =
+ (match inductive_arg with
+ Con.Aux n -> B.b_kw "an aux???"
+ | Con.Premise prem ->
+ (match prem.Con.premise_binder with
+ None -> B.b_kw "the previous result"
+ | Some n -> B.Object ([], P.Mi([],n)))
+ | Con.Lemma lemma -> B.Object ([], P.Mi([],lemma.Con.lemma_name))
+ | Con.Term t ->
+ term2pres t
+ | Con.ArgProof p -> B.b_kw "a proof???"
+ | Con.ArgMethod s -> B.b_kw "a method???") in
+ (make_concl "we proceed by induction on" arg) in
+ let to_prove =
+ (make_concl "to prove" proof_conclusion) in
+ B.V ([], induction_on::to_prove:: (make_cases args_for_cases))
+
+ and make_cases l = List.map make_case l
+
+ and make_case =
+ function
+ Con.ArgProof p ->
+ let name =
+ (match p.Con.proof_name with
+ None -> B.b_kw "no name for case!!"
+ | Some n -> B.Object ([], P.Mi([],n))) in
+ let indhyps,args =
+ List.partition
+ (function
+ `Hypothesis h -> h.Con.dec_inductive
+ | _ -> false) p.Con.proof_context in
+ let pattern_aux =
+ List.fold_right
+ (fun e p ->
+ let dec =
+ (match e with
+ `Declaration h
+ | `Hypothesis h ->
+ let name =
+ (match h.Con.dec_name with
+ None -> "NO NAME???"
+ | Some n ->n) in
+ [B.b_space;
+ B.Object ([], P.Mi ([],name));
+ B.Text([],":");
+ (term2pres h.Con.dec_type)]
+ | _ -> [B.Text ([],"???")]) in
+ dec@p) args [] in
+ let pattern =
+ B.H ([],
+ (B.b_kw "Case"::B.b_space::name::pattern_aux)@
+ [B.b_space;
+ B.Text([], Utf8Macro.unicode_of_tex "\\Rightarrow")]) in
+ let subconcl =
+ (match p.Con.proof_conclude.Con.conclude_conclusion with
+ None -> B.b_kw "No conclusion!!!"
+ | Some t -> term2pres t) in
+ let asubconcl = B.indent (make_concl "the thesis becomes" subconcl) in
+ let induction_hypothesis =
+ (match indhyps with
+ [] -> []
+ | _ ->
+ let text = B.indent (B.b_kw "by induction hypothesis we know") in
+ let make_hyp =
+ function
+ `Hypothesis h ->
+ let name =
+ (match h.Con.dec_name with
+ None -> "no name"
+ | Some s -> s) in
+ B.indent (B.H ([],
+ [B.Text([],"(");
+ B.Object ([], P.Mi ([],name));
+ B.Text([],")");
+ B.b_space;
+ term2pres h.Con.dec_type]))
+ | _ -> assert false in
+ let hyps = List.map make_hyp indhyps in
+ text::hyps) in
+ (* let acontext =
+ acontext2pres_old p.Con.proof_apply_context true in *)
+ let body = conclude2pres p.Con.proof_conclude true false in
+ let presacontext =
+ let acontext_id =
+ match p.Con.proof_apply_context with
+ [] -> p.Con.proof_conclude.Con.conclude_id
+ | {Con.proof_id = id}::_ -> id
+ in
+ B.Action([None,"type","toggle"],
+ [ B.indent (add_xref acontext_id (B.b_kw "Proof"));
+ acontext2pres p.Con.proof_apply_context body true]) in
+ B.V ([], pattern::asubconcl::induction_hypothesis@[presacontext])
+ | _ -> assert false
+
+ and falseind conclude =
+ let proof_conclusion =
+ (match conclude.Con.conclude_conclusion with
+ None -> B.b_kw "No conclusion???"
+ | Some t -> term2pres t) in
+ let case_arg =
+ (match conclude.Con.conclude_args with
+ [Con.Aux(n);_;case_arg] -> case_arg
+ | _ -> assert false;
+ (*
+ List.map (ContentPp.parg 0) conclude.Con.conclude_args;
+ assert false *)) in
+ let arg =
+ (match case_arg with
+ Con.Aux n -> assert false
+ | Con.Premise prem ->
+ (match prem.Con.premise_binder with
+ None -> [B.b_kw "Contradiction, hence"]
+ | Some n ->
+ [ B.Object ([],P.Mi([],n)); B.skip;
+ B.b_kw "is contradictory, hence"])
+ | Con.Lemma lemma ->
+ [ B.Object ([], P.Mi([],lemma.Con.lemma_name)); B.skip;
+ B.b_kw "is contradictory, hence" ]
+ | _ -> assert false) in
+ (* let body = proof2pres {proof with Con.proof_context = tl} in *)
+ make_row arg proof_conclusion
+
+ and andind conclude =
+ let proof_conclusion =
+ (match conclude.Con.conclude_conclusion with
+ None -> B.b_kw "No conclusion???"
+ | Some t -> term2pres t) in
+ let proof,case_arg =
+ (match conclude.Con.conclude_args with
+ [Con.Aux(n);_;Con.ArgProof proof;case_arg] -> proof,case_arg
+ | _ -> assert false;
+ (*
+ List.map (ContentPp.parg 0) conclude.Con.conclude_args;
+ assert false *)) in
+ let arg =
+ (match case_arg with
+ Con.Aux n -> assert false
+ | Con.Premise prem ->
+ (match prem.Con.premise_binder with
+ None -> []
+ | Some n -> [(B.b_kw "by"); B.b_space; B.Object([], P.Mi([],n))])
+ | Con.Lemma lemma ->
+ [(B.b_kw "by");B.skip;
+ B.Object([], P.Mi([],lemma.Con.lemma_name))]
+ | _ -> assert false) in
+ match proof.Con.proof_context with
+ `Hypothesis hyp1::`Hypothesis hyp2::tl ->
+ let get_name hyp =
+ (match hyp.Con.dec_name with
+ None -> "_"
+ | Some s -> s) in
+ let preshyp1 =
+ B.H ([],
+ [B.Text([],"(");
+ B.Object ([], P.Mi([],get_name hyp1));
+ B.Text([],")");
+ B.skip;
+ term2pres hyp1.Con.dec_type]) in
+ let preshyp2 =
+ B.H ([],
+ [B.Text([],"(");
+ B.Object ([], P.Mi([],get_name hyp2));
+ B.Text([],")");
+ B.skip;
+ term2pres hyp2.Con.dec_type]) in
+ (* let body = proof2pres {proof with Con.proof_context = tl} in *)
+ let body = conclude2pres proof.Con.proof_conclude false true in
+ let presacontext =
+ acontext2pres proof.Con.proof_apply_context body false in
+ B.V
+ ([],
+ [B.H ([],arg@[B.skip; B.b_kw "we have"]);
+ preshyp1;
+ B.b_kw "and";
+ preshyp2;
+ presacontext]);
+ | _ -> assert false
+
+ and exists conclude =
+ let proof_conclusion =
+ (match conclude.Con.conclude_conclusion with
+ None -> B.b_kw "No conclusion???"
+ | Some t -> term2pres t) in
+ let proof =
+ (match conclude.Con.conclude_args with
+ [Con.Aux(n);_;Con.ArgProof proof;_] -> proof
+ | _ -> assert false;
+ (*
+ List.map (ContentPp.parg 0) conclude.Con.conclude_args;
+ assert false *)) in
+ match proof.Con.proof_context with
+ `Declaration decl::`Hypothesis hyp::tl
+ | `Hypothesis decl::`Hypothesis hyp::tl ->
+ let get_name decl =
+ (match decl.Con.dec_name with
+ None -> "_"
+ | Some s -> s) in
+ let presdecl =
+ B.H ([],
+ [(B.b_kw "let");
+ B.skip;
+ B.Object ([], P.Mi([],get_name decl));
+ B.Text([],":"); term2pres decl.Con.dec_type]) in
+ let suchthat =
+ B.H ([],
+ [(B.b_kw "such that");
+ B.skip;
+ B.Text([],"(");
+ B.Object ([], P.Mi([],get_name hyp));
+ B.Text([],")");
+ B.skip;
+ term2pres hyp.Con.dec_type]) in
+ (* let body = proof2pres {proof with Con.proof_context = tl} in *)
+ let body = conclude2pres proof.Con.proof_conclude false true in
+ let presacontext =
+ acontext2pres proof.Con.proof_apply_context body false in
+ B.V
+ ([],
+ [presdecl;
+ suchthat;
+ presacontext]);
+ | _ -> assert false
+
+ in
+ proof2pres p
+
+exception ToDo
+
+let counter = ref 0
+
+let conjecture2pres term2pres (id, n, context, ty) =
+ (B.b_h [Some "helm", "xref", id]
+ (((List.map
+ (function
+ | None ->
+ B.b_h []
+ [ B.b_object (p_mi [] "_") ;
+ B.b_object (p_mo [] ":?") ;
+ B.b_object (p_mi [] "_")]
+ | Some (`Declaration d)
+ | Some (`Hypothesis d) ->
+ let { Content.dec_name =
+ dec_name ; Content.dec_type = ty } = d
+ in
+ B.b_h []
+ [ B.b_object
+ (p_mi []
+ (match dec_name with
+ None -> "_"
+ | Some n -> n));
+ B.b_text [] ":";
+ term2pres ty ]
+ | Some (`Definition d) ->
+ let
+ { Content.def_name = def_name ;
+ Content.def_term = bo } = d
+ in
+ B.b_h []
+ [ B.b_object (p_mi []
+ (match def_name with
+ None -> "_"
+ | Some n -> n)) ;
+ B.b_text [] (Utf8Macro.unicode_of_tex "\\Assign");
+ term2pres bo]
+ | Some (`Proof p) ->
+ let proof_name = p.Content.proof_name in
+ B.b_h []
+ [ B.b_object (p_mi []
+ (match proof_name with
+ None -> "_"
+ | Some n -> n)) ;
+ B.b_text [] (Utf8Macro.unicode_of_tex "\\Assign");
+ proof2pres term2pres p])
+ (List.rev context)) @
+ [ B.b_text [] (Utf8Macro.unicode_of_tex "\\vdash");
+ B.b_object (p_mi [] (string_of_int n)) ;
+ B.b_text [] ":" ;
+ term2pres ty ])))
+
+let metasenv2pres term2pres = function
+ | None -> []
+ | Some metasenv' ->
+ (* Conjectures are in their own table to make *)
+ (* diffing the DOM trees easier. *)
+ [B.b_v []
+ ((B.b_kw ("Conjectures:" ^
+ (let _ = incr counter; in (string_of_int !counter)))) ::
+ (List.map (conjecture2pres term2pres) metasenv'))]
+
+let params2pres params =
+ let param2pres uri =
+ B.b_text [Some "xlink", "href", UriManager.string_of_uri uri]
+ (UriManager.name_of_uri uri)
+ in
+ let rec spatiate = function
+ | [] -> []
+ | hd :: [] -> [hd]
+ | hd :: tl -> hd :: B.b_text [] ", " :: spatiate tl
+ in
+ match params with
+ | [] -> []
+ | p ->
+ let params = spatiate (List.map param2pres p) in
+ [B.b_space;
+ B.b_h [] (B.b_text [] "[" :: params @ [ B.b_text [] "]" ])]
+
+let recursion_kind2pres params kind =
+ let kind =
+ match kind with
+ | `Recursive _ -> "Recursive definition"
+ | `CoRecursive -> "CoRecursive definition"
+ | `Inductive _ -> "Inductive definition"
+ | `CoInductive _ -> "CoInductive definition"
+ in
+ B.b_h [] (B.b_kw kind :: params2pres params)
+
+let inductive2pres term2pres ind =
+ let constructor2pres decl =
+ B.b_h [] [
+ B.b_text [] ("| " ^ get_name decl.Content.dec_name ^ ":");
+ B.b_space;
+ term2pres decl.Content.dec_type
+ ]
+ in
+ B.b_v []
+ (B.b_h [] [
+ B.b_kw (ind.Content.inductive_name ^ " of arity");
+ B.smallskip;
+ term2pres ind.Content.inductive_type ]
+ :: List.map constructor2pres ind.Content.inductive_constructors)
+
+let joint_def2pres term2pres def =
+ match def with
+ | `Inductive ind -> inductive2pres term2pres ind
+ | _ -> assert false (* ZACK or raise ToDo? *)
+
+let content2pres term2pres (id,params,metasenv,obj) =
+ match obj with
+ | `Def (Content.Const, thesis, `Proof p) ->
+ let name = get_name p.Content.proof_name in
+ B.b_v
+ [Some "helm","xref","id"]
+ ([ B.b_h [] (B.b_kw ("Proof " ^ name) :: params2pres params);
+ B.b_kw "Thesis:";
+ B.indent (term2pres thesis) ] @
+ metasenv2pres term2pres metasenv @
+ [proof2pres term2pres p])
+ | `Def (_, ty, `Definition body) ->
+ let name = get_name body.Content.def_name in
+ B.b_v
+ [Some "helm","xref","id"]
+ ([B.b_h [] (B.b_kw ("Definition " ^ name) :: params2pres params);
+ B.b_kw "Type:";
+ B.indent (term2pres ty)] @
+ metasenv2pres term2pres metasenv @
+ [B.b_kw "Body:"; term2pres body.Content.def_term])
+ | `Decl (_, `Declaration decl)
+ | `Decl (_, `Hypothesis decl) ->
+ let name = get_name decl.Content.dec_name in
+ B.b_v
+ [Some "helm","xref","id"]
+ ([B.b_h [] (B.b_kw ("Axiom " ^ name) :: params2pres params);
+ B.b_kw "Type:";
+ B.indent (term2pres decl.Content.dec_type)] @
+ metasenv2pres term2pres metasenv)
+ | `Joint joint ->
+ B.b_v []
+ (recursion_kind2pres params joint.Content.joint_kind
+ :: List.map (joint_def2pres term2pres) joint.Content.joint_defs)
+ | _ -> raise ToDo
+
+let content2pres ~ids_to_inner_sorts =
+ content2pres
+ (fun annterm ->
+ let ast, ids_to_uris =
+ TermAcicContent.ast_of_acic ids_to_inner_sorts annterm
+ in
+ CicNotationPres.box_of_mpres
+ (CicNotationPres.render ids_to_uris
+ (TermContentPres.pp_ast ast)))
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(**************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Andrea Asperti <asperti@cs.unibo.it> *)
+(* 27/6/2003 *)
+(* *)
+(**************************************************************************)
+
+val content2pres:
+ ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t ->
+ Cic.annterm Content.cobj ->
+ CicNotationPres.boxml_markup
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Printf
+
+module Ast = CicNotationPt
+module Env = CicNotationEnv
+module Pp = CicNotationPp
+module Util = CicNotationUtil
+
+let get_tag term0 =
+ let subterms = ref [] in
+ let map_term t =
+ subterms := t :: !subterms ;
+ Ast.Implicit
+ in
+ let rec aux t = CicNotationUtil.visit_ast ~special_k map_term t
+ and special_k = function
+ | Ast.AttributedTerm (_, t) -> aux t
+ | _ -> assert false
+ in
+ let term_mask = aux term0 in
+ let tag = Hashtbl.hash term_mask in
+ tag, List.rev !subterms
+
+module Matcher21 =
+struct
+ module Pattern21 =
+ struct
+ type pattern_t = Ast.term
+ type term_t = Ast.term
+ let rec classify = function
+ | Ast.AttributedTerm (_, t) -> classify t
+ | Ast.Variable _ -> PatternMatcher.Variable
+ | Ast.Magic _
+ | Ast.Layout _
+ | Ast.Literal _ as t -> assert false
+ | _ -> PatternMatcher.Constructor
+ let tag_of_pattern = get_tag
+ let tag_of_term t = get_tag t
+ let string_of_term = CicNotationPp.pp_term
+ let string_of_pattern = CicNotationPp.pp_term
+ end
+
+ module M = PatternMatcher.Matcher (Pattern21)
+
+ let extract_magic term =
+ let magic_map = ref [] in
+ let add_magic m =
+ let name = Util.fresh_name () in
+ magic_map := (name, m) :: !magic_map;
+ Ast.Variable (Ast.TermVar name)
+ in
+ let rec aux = function
+ | Ast.AttributedTerm (_, t) -> assert false
+ | Ast.Literal _
+ | Ast.Layout _ -> assert false
+ | Ast.Variable v -> Ast.Variable v
+ | Ast.Magic m -> add_magic m
+ | t -> Util.visit_ast aux t
+ in
+ let term' = aux term in
+ term', !magic_map
+
+ let env_of_matched pl tl =
+ try
+ List.map2
+ (fun p t ->
+ match p, t with
+ Ast.Variable (Ast.TermVar name), _ ->
+ name, (Env.TermType, Env.TermValue t)
+ | Ast.Variable (Ast.NumVar name), (Ast.Num (s, _)) ->
+ name, (Env.NumType, Env.NumValue s)
+ | Ast.Variable (Ast.IdentVar name), (Ast.Ident (s, None)) ->
+ name, (Env.StringType, Env.StringValue s)
+ | _ -> assert false)
+ pl tl
+ with Invalid_argument _ -> assert false
+
+ let rec compiler rows =
+ let rows', magic_maps =
+ List.split
+ (List.map
+ (fun (p, pid) ->
+ let p', map = extract_magic p in
+ (p', pid), (pid, map))
+ rows)
+ in
+ let magichecker map =
+ List.fold_left
+ (fun f (name, m) ->
+ let m_checker = compile_magic m in
+ (fun env ctors ->
+ match m_checker (Env.lookup_term env name) env ctors with
+ | None -> None
+ | Some (env, ctors) -> f env ctors))
+ (fun env ctors -> Some (env, ctors))
+ map
+ in
+ let magichooser candidates =
+ List.fold_left
+ (fun f (pid, pl, checker) ->
+ (fun matched_terms constructors ->
+ let env = env_of_matched pl matched_terms in
+ match checker env constructors with
+ | None -> f matched_terms constructors
+ | Some (env, ctors') ->
+ let magic_map =
+ try List.assoc pid magic_maps with Not_found -> assert false
+ in
+ let env' = Env.remove_names env (List.map fst magic_map) in
+ Some (env', ctors', pid)))
+ (fun _ _ -> None)
+ (List.rev candidates)
+ in
+ let match_cb rows =
+ let candidates =
+ List.map
+ (fun (pl, pid) ->
+ let magic_map =
+ try List.assoc pid magic_maps with Not_found -> assert false
+ in
+ pid, pl, magichecker magic_map)
+ rows
+ in
+ magichooser candidates
+ in
+ M.compiler rows' match_cb (fun _ -> None)
+
+ and compile_magic = function
+ | Ast.Fold (kind, p_base, names, p_rec) ->
+ let p_rec_decls = Env.declarations_of_term p_rec in
+ (* LUCA: p_rec_decls should not contain "names" *)
+ let acc_name = try List.hd names with Failure _ -> assert false in
+ let compiled_base = compiler [p_base, 0]
+ and compiled_rec = compiler [p_rec, 0] in
+ (fun term env ctors ->
+ let aux_base term =
+ match compiled_base term with
+ | None -> None
+ | Some (env', ctors', _) -> Some (env', ctors', [])
+ in
+ let rec aux term =
+ match compiled_rec term with
+ | None -> aux_base term
+ | Some (env', ctors', _) ->
+ begin
+ let acc = Env.lookup_term env' acc_name in
+ let env'' = Env.remove_name env' acc_name in
+ match aux acc with
+ | None -> aux_base term
+ | Some (base_env, ctors', rec_envl) ->
+ let ctors'' = ctors' @ ctors in
+ Some (base_env, ctors'',env'' :: rec_envl)
+ end
+ in
+ match aux term with
+ | None -> None
+ | Some (base_env, ctors, rec_envl) ->
+ let env' =
+ base_env @ Env.coalesce_env p_rec_decls rec_envl @ env
+ (* @ env LUCA!!! *)
+ in
+ Some (env', ctors))
+
+ | Ast.Default (p_some, p_none) -> (* p_none can't bound names *)
+ let p_some_decls = Env.declarations_of_term p_some in
+ let p_none_decls = Env.declarations_of_term p_none in
+ let p_opt_decls =
+ List.filter
+ (fun decl -> not (List.mem decl p_none_decls))
+ p_some_decls
+ in
+ let none_env = List.map Env.opt_binding_of_name p_opt_decls in
+ let compiled = compiler [p_some, 0] in
+ (fun term env ctors ->
+ match compiled term with
+ | None -> Some (none_env, ctors) (* LUCA: @ env ??? *)
+ | Some (env', ctors', 0) ->
+ let env' =
+ List.map
+ (fun (name, (ty, v)) as binding ->
+ if List.exists (fun (name', _) -> name = name') p_opt_decls
+ then Env.opt_binding_some binding
+ else binding)
+ env'
+ in
+ Some (env' @ env, ctors' @ ctors)
+ | _ -> assert false)
+
+ | Ast.If (p_test, p_true, p_false) ->
+ let compiled_test = compiler [p_test, 0]
+ and compiled_true = compiler [p_true, 0]
+ and compiled_false = compiler [p_false, 0] in
+ (fun term env ctors ->
+ let branch =
+ match compiled_test term with
+ | None -> compiled_false
+ | Some _ -> compiled_true
+ in
+ match branch term with
+ | None -> None
+ | Some (env', ctors', _) -> Some (env' @ env, ctors' @ ctors))
+
+ | Ast.Fail -> (fun _ _ _ -> None)
+
+ | _ -> assert false
+end
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+module Matcher21:
+sig
+ (** @param l2_patterns level 2 (AST) patterns *)
+ val compiler :
+ (CicNotationPt.term * int) list ->
+ (CicNotationPt.term ->
+ (CicNotationEnv.t * CicNotationPt.term list * int) option)
+end
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(**************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Andrea Asperti <asperti@cs.unibo.it> *)
+(* 16/62003 *)
+(* *)
+(**************************************************************************)
+
+type 'a mpres =
+ Mi of attr * string
+ | Mn of attr * string
+ | Mo of attr * string
+ | Mtext of attr * string
+ | Mspace of attr
+ | Ms of attr * string
+ | Mgliph of attr * string
+ | Mrow of attr * 'a mpres list
+ | Mfrac of attr * 'a mpres * 'a mpres
+ | Msqrt of attr * 'a mpres
+ | Mroot of attr * 'a mpres * 'a mpres
+ | Mstyle of attr * 'a mpres
+ | Merror of attr * 'a mpres
+ | Mpadded of attr * 'a mpres
+ | Mphantom of attr * 'a mpres
+ | Mfenced of attr * 'a mpres list
+ | Menclose of attr * 'a mpres
+ | Msub of attr * 'a mpres * 'a mpres
+ | Msup of attr * 'a mpres * 'a mpres
+ | Msubsup of attr * 'a mpres * 'a mpres *'a mpres
+ | Munder of attr * 'a mpres * 'a mpres
+ | Mover of attr * 'a mpres * 'a mpres
+ | Munderover of attr * 'a mpres * 'a mpres *'a mpres
+(* | Multiscripts of ??? NOT IMPLEMEMENTED *)
+ | Mtable of attr * 'a row list
+ | Maction of attr * 'a mpres list
+ | Mobject of attr * 'a
+and 'a row = Mtr of attr * 'a mtd list
+and 'a mtd = Mtd of attr * 'a mpres
+and attr = (string option * string * string) list
+;;
+
+let smallskip = Mspace([None,"width","0.5em"]);;
+let indentation = Mspace([None,"width","1em"]);;
+
+let indented elem =
+ Mrow([],[indentation;elem]);;
+
+let standard_tbl_attr =
+ [None,"align","baseline 1";None,"equalrows","false";None,"columnalign","left"]
+;;
+
+let two_rows_table attr a b =
+ Mtable(attr@standard_tbl_attr,
+ [Mtr([],[Mtd([],a)]);
+ Mtr([],[Mtd([],b)])]);;
+
+let two_rows_table_with_brackets attr a b op =
+ (* only the open bracket is added; the closed bracket must be in b *)
+ Mtable(attr@standard_tbl_attr,
+ [Mtr([],[Mtd([],Mrow([],[Mtext([],"(");a]))]);
+ Mtr([],[Mtd([],Mrow([],[indentation;op;b]))])]);;
+
+let two_rows_table_without_brackets attr a b op =
+ Mtable(attr@standard_tbl_attr,
+ [Mtr([],[Mtd([],a)]);
+ Mtr([],[Mtd([],Mrow([],[indentation;op;b]))])]);;
+
+let row_with_brackets attr a b op =
+ (* by analogy with two_rows_table_with_brackets we only add the
+ open brackets *)
+ Mrow(attr,[Mtext([],"(");a;op;b;Mtext([],")")])
+
+let row_without_brackets attr a b op =
+ Mrow(attr,[a;op;b])
+
+(* MathML prefix *)
+let prefix = "m";;
+
+let print_mpres obj_printer mpres =
+ let module X = Xml in
+ let rec aux =
+ function
+ Mi (attr,s) -> X.xml_nempty ~prefix "mi" attr (X.xml_cdata s)
+ | Mn (attr,s) -> X.xml_nempty ~prefix "mn" attr (X.xml_cdata s)
+ | Mo (attr,s) ->
+ let s =
+ let len = String.length s in
+ if len > 1 && s.[0] = '\\'
+ then String.sub s 1 (len - 1)
+ else s
+ in
+ X.xml_nempty ~prefix "mo" attr (X.xml_cdata s)
+ | Mtext (attr,s) -> X.xml_nempty ~prefix "mtext" attr (X.xml_cdata s)
+ | Mspace attr -> X.xml_empty ~prefix "mspace" attr
+ | Ms (attr,s) -> X.xml_nempty ~prefix "ms" attr (X.xml_cdata s)
+ | Mgliph (attr,s) -> X.xml_nempty ~prefix "mgliph" attr (X.xml_cdata s)
+ (* General Layout Schemata *)
+ | Mrow (attr,l) ->
+ X.xml_nempty ~prefix "mrow" attr
+ [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>])
+ >]
+ | Mfrac (attr,m1,m2) ->
+ X.xml_nempty ~prefix "mfrac" attr [< aux m1; aux m2 >]
+ | Msqrt (attr,m) ->
+ X.xml_nempty ~prefix "msqrt" attr [< aux m >]
+ | Mroot (attr,m1,m2) ->
+ X.xml_nempty ~prefix "mroot" attr [< aux m1; aux m2 >]
+ | Mstyle (attr,m) -> X.xml_nempty ~prefix "mstyle" attr [< aux m >]
+ | Merror (attr,m) -> X.xml_nempty ~prefix "merror" attr [< aux m >]
+ | Mpadded (attr,m) -> X.xml_nempty ~prefix "mpadded" attr [< aux m >]
+ | Mphantom (attr,m) -> X.xml_nempty ~prefix "mphantom" attr [< aux m >]
+ | Mfenced (attr,l) ->
+ X.xml_nempty ~prefix "mfenced" attr
+ [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>])
+ >]
+ | Menclose (attr,m) -> X.xml_nempty ~prefix "menclose" attr [< aux m >]
+ (* Script and Limit Schemata *)
+ | Msub (attr,m1,m2) ->
+ X.xml_nempty ~prefix "msub" attr [< aux m1; aux m2 >]
+ | Msup (attr,m1,m2) ->
+ X.xml_nempty ~prefix "msup" attr [< aux m1; aux m2 >]
+ | Msubsup (attr,m1,m2,m3) ->
+ X.xml_nempty ~prefix "msubsup" attr [< aux m1; aux m2; aux m3 >]
+ | Munder (attr,m1,m2) ->
+ X.xml_nempty ~prefix "munder" attr [< aux m1; aux m2 >]
+ | Mover (attr,m1,m2) ->
+ X.xml_nempty ~prefix "mover" attr [< aux m1; aux m2 >]
+ | Munderover (attr,m1,m2,m3) ->
+ X.xml_nempty ~prefix "munderover" attr [< aux m1; aux m2; aux m3 >]
+ (* | Multiscripts of ??? NOT IMPLEMEMENTED *)
+ (* Tables and Matrices *)
+ | Mtable (attr, rl) ->
+ X.xml_nempty ~prefix "mtable" attr
+ [< (List.fold_right (fun x i -> [< (aux_mrow x) ; i >]) rl [<>]) >]
+ (* Enlivening Expressions *)
+ | Maction (attr, l) ->
+ X.xml_nempty ~prefix "maction" attr
+ [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) >]
+ | Mobject (attr, obj) ->
+ let box_stream = obj_printer obj in
+ X.xml_nempty ~prefix "semantics" attr
+ [< X.xml_nempty ~prefix "annotation-xml" [None, "encoding", "BoxML"]
+ box_stream >]
+
+ and aux_mrow =
+ let module X = Xml in
+ function
+ Mtr (attr, l) ->
+ X.xml_nempty ~prefix "mtr" attr
+ [< (List.fold_right (fun x i -> [< (aux_mtd x) ; i >]) l [<>])
+ >]
+ and aux_mtd =
+ let module X = Xml in
+ function
+ Mtd (attr,m) -> X.xml_nempty ~prefix "mtd" attr
+ [< (aux m) ;
+ X.xml_nempty ~prefix "mphantom" []
+ (X.xml_nempty ~prefix "mtext" [] (X.xml_cdata "(")) >]
+ in
+ aux mpres
+;;
+
+let document_of_mpres pres =
+ [< Xml.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ Xml.xml_cdata "\n";
+ Xml.xml_nempty ~prefix "math"
+ [Some "xmlns","m","http://www.w3.org/1998/Math/MathML" ;
+ Some "xmlns","helm","http://www.cs.unibo.it/helm" ;
+ Some "xmlns","xlink","http://www.w3.org/1999/xlink"
+ ] (Xml.xml_nempty ~prefix "mstyle" [None, "mathvariant", "normal"; None,
+ "rowspacing", "0.6ex"] (print_mpres (fun _ -> assert false) pres))
+ >]
+
+let get_attr = function
+ | Maction (attr, _)
+ | Menclose (attr, _)
+ | Merror (attr, _)
+ | Mfenced (attr, _)
+ | Mfrac (attr, _, _)
+ | Mgliph (attr, _)
+ | Mi (attr, _)
+ | Mn (attr, _)
+ | Mo (attr, _)
+ | Mobject (attr, _)
+ | Mover (attr, _, _)
+ | Mpadded (attr, _)
+ | Mphantom (attr, _)
+ | Mroot (attr, _, _)
+ | Mrow (attr, _)
+ | Ms (attr, _)
+ | Mspace attr
+ | Msqrt (attr, _)
+ | Mstyle (attr, _)
+ | Msub (attr, _, _)
+ | Msubsup (attr, _, _, _)
+ | Msup (attr, _, _)
+ | Mtable (attr, _)
+ | Mtext (attr, _)
+ | Munder (attr, _, _)
+ | Munderover (attr, _, _, _) ->
+ attr
+
+let set_attr attr = function
+ | Maction (_, x) -> Maction (attr, x)
+ | Menclose (_, x) -> Menclose (attr, x)
+ | Merror (_, x) -> Merror (attr, x)
+ | Mfenced (_, x) -> Mfenced (attr, x)
+ | Mfrac (_, x, y) -> Mfrac (attr, x, y)
+ | Mgliph (_, x) -> Mgliph (attr, x)
+ | Mi (_, x) -> Mi (attr, x)
+ | Mn (_, x) -> Mn (attr, x)
+ | Mo (_, x) -> Mo (attr, x)
+ | Mobject (_, x) -> Mobject (attr, x)
+ | Mover (_, x, y) -> Mover (attr, x, y)
+ | Mpadded (_, x) -> Mpadded (attr, x)
+ | Mphantom (_, x) -> Mphantom (attr, x)
+ | Mroot (_, x, y) -> Mroot (attr, x, y)
+ | Mrow (_, x) -> Mrow (attr, x)
+ | Ms (_, x) -> Ms (attr, x)
+ | Mspace _ -> Mspace attr
+ | Msqrt (_, x) -> Msqrt (attr, x)
+ | Mstyle (_, x) -> Mstyle (attr, x)
+ | Msub (_, x, y) -> Msub (attr, x, y)
+ | Msubsup (_, x, y, z) -> Msubsup (attr, x, y, z)
+ | Msup (_, x, y) -> Msup (attr, x, y)
+ | Mtable (_, x) -> Mtable (attr, x)
+ | Mtext (_, x) -> Mtext (attr, x)
+ | Munder (_, x, y) -> Munder (attr, x, y)
+ | Munderover (_, x, y, z) -> Munderover (attr, x, y, z)
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+type 'a mpres =
+ (* token elements *)
+ Mi of attr * string
+ | Mn of attr * string
+ | Mo of attr * string
+ | Mtext of attr * string
+ | Mspace of attr
+ | Ms of attr * string
+ | Mgliph of attr * string
+ (* General Layout Schemata *)
+ | Mrow of attr * 'a mpres list
+ | Mfrac of attr * 'a mpres * 'a mpres
+ | Msqrt of attr * 'a mpres
+ | Mroot of attr * 'a mpres * 'a mpres
+ | Mstyle of attr * 'a mpres
+ | Merror of attr * 'a mpres
+ | Mpadded of attr * 'a mpres
+ | Mphantom of attr * 'a mpres
+ | Mfenced of attr * 'a mpres list
+ | Menclose of attr * 'a mpres
+ (* Script and Limit Schemata *)
+ | Msub of attr * 'a mpres * 'a mpres
+ | Msup of attr * 'a mpres * 'a mpres
+ | Msubsup of attr * 'a mpres * 'a mpres *'a mpres
+ | Munder of attr * 'a mpres * 'a mpres
+ | Mover of attr * 'a mpres * 'a mpres
+ | Munderover of attr * 'a mpres * 'a mpres *'a mpres
+ (* Tables and Matrices *)
+ | Mtable of attr * 'a row list
+ (* Enlivening Expressions *)
+ | Maction of attr * 'a mpres list
+ (* Embedding *)
+ | Mobject of attr * 'a
+
+and 'a row = Mtr of attr * 'a mtd list
+
+and 'a mtd = Mtd of attr * 'a mpres
+
+ (** XML attribute: namespace, name, value *)
+and attr = (string option * string * string) list
+
+;;
+
+val get_attr: 'a mpres -> attr
+val set_attr: attr -> 'a mpres -> 'a mpres
+
+val smallskip : 'a mpres
+val indented : 'a mpres -> 'a mpres
+val standard_tbl_attr : attr
+val two_rows_table : attr -> 'a mpres -> 'a mpres -> 'a mpres
+val two_rows_table_with_brackets :
+ attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres
+val two_rows_table_without_brackets :
+ attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres
+val row_with_brackets :
+ attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres
+val row_without_brackets :
+ attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres
+val print_mpres : ('a -> Xml.token Stream.t) -> 'a mpres -> Xml.token Stream.t
+val document_of_mpres : 'a mpres -> Xml.token Stream.t
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+type xml_attribute = string option * string * string
+type markup = [ `MathML | `BoxML ]
+
+let keyword_attributes = function
+ | `MathML -> [ None, "mathcolor", "blue" ]
+ | `BoxML -> [ None, "color", "blue" ]
+
+let builtin_symbol_attributes = function
+ | `MathML -> [ None, "mathcolor", "blue" ]
+ | `BoxML -> [ None, "color", "blue" ]
+
+let object_keyword_attributes = function
+ | `MathML -> [ None, "mathcolor", "red" ]
+ | `BoxML -> [ None, "color", "red" ]
+
+let symbol_attributes _ = []
+let ident_attributes _ = []
+let number_attributes _ = []
+
+let spacing_attributes _ = [ None, "spacing", "0.5em" ]
+let indent_attributes _ = [ None, "indent", "0.5em" ]
+let small_skip_attributes _ = [ None, "width", "0.5em" ]
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(** XML attributes for MathML/BoxML rendering of terms and objects
+ * markup defaults to MathML in all functions below *)
+
+type xml_attribute = string option * string * string
+type markup = [ `MathML | `BoxML ]
+
+(** High-level attributes *)
+
+val keyword_attributes: (* let, match, in, ... *)
+ markup -> xml_attribute list
+
+val builtin_symbol_attributes: (* \\Pi, \\to, ... *)
+ markup -> xml_attribute list
+
+val symbol_attributes: (* +, *, ... *)
+ markup -> xml_attribute list
+
+val ident_attributes: (* nat, plus, ... *)
+ markup -> xml_attribute list
+
+val number_attributes: (* 1, 2, ... *)
+ markup -> xml_attribute list
+
+val object_keyword_attributes: (* Body, Definition, ... *)
+ markup -> xml_attribute list
+
+(** Low-level attributes *)
+
+val spacing_attributes: markup -> xml_attribute list
+val indent_attributes: markup -> xml_attribute list
+val small_skip_attributes: markup -> xml_attribute list
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(***************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Andrea Asperti <asperti@cs.unibo.it> *)
+(* 19/11/2003 *)
+(* *)
+(***************************************************************************)
+
+let p_mtr a b = Mpresentation.Mtr(a,b)
+let p_mtd a b = Mpresentation.Mtd(a,b)
+let p_mtable a b = Mpresentation.Mtable(a,b)
+let p_mtext a b = Mpresentation.Mtext(a,b)
+let p_mi a b = Mpresentation.Mi(a,b)
+let p_mo a b = Mpresentation.Mo(a,b)
+let p_mrow a b = Mpresentation.Mrow(a,b)
+let p_mphantom a b = Mpresentation.Mphantom(a,b)
+let b_ink a = Box.Ink a
+
+module K = Content
+module P = Mpresentation
+
+let sequent2pres term2pres (_,_,context,ty) =
+ let context2pres context =
+ let rec aux accum =
+ function
+ [] -> accum
+ | None::tl -> aux accum tl
+ | (Some (`Declaration d))::tl ->
+ let
+ { K.dec_name = dec_name ;
+ K.dec_id = dec_id ;
+ K.dec_type = ty } = d in
+ let r =
+ Box.b_h [Some "helm", "xref", dec_id]
+ [ Box.b_object (p_mi []
+ (match dec_name with
+ None -> "_"
+ | Some n -> n)) ;
+ Box.b_text [] ":" ;
+ term2pres ty] in
+ aux (r::accum) tl
+ | (Some (`Definition d))::tl ->
+ let
+ { K.def_name = def_name ;
+ K.def_id = def_id ;
+ K.def_term = bo } = d in
+ let r =
+ Box.b_h [Some "helm", "xref", def_id]
+ [ Box.b_object (p_mi []
+ (match def_name with
+ None -> "_"
+ | Some n -> n)) ;
+ Box.b_text [] (Utf8Macro.unicode_of_tex "\\def") ;
+ term2pres bo] in
+ aux (r::accum) tl
+ | _::_ -> assert false in
+ aux [] context in
+ let pres_context = (Box.b_v [] (context2pres context)) in
+ let pres_goal = term2pres ty in
+ (Box.b_h [] [
+ Box.b_space;
+ (Box.b_v []
+ [Box.b_space;
+ pres_context;
+ b_ink [None,"width","4cm"; None,"height","2px"]; (* sequent line *)
+ Box.b_space;
+ pres_goal])])
+
+let sequent2pres ~ids_to_inner_sorts =
+ sequent2pres
+ (fun annterm ->
+ let ast, ids_to_uris =
+ TermAcicContent.ast_of_acic ids_to_inner_sorts annterm
+ in
+ CicNotationPres.box_of_mpres
+ (CicNotationPres.render ids_to_uris
+ (TermContentPres.pp_ast ast)))
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(***************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Andrea Asperti <asperti@cs.unibo.it> *)
+(* 19/11/2003 *)
+(* *)
+(***************************************************************************)
+
+val sequent2pres :
+ ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t ->
+ Cic.annterm Content.conjecture ->
+ CicNotationPres.boxml_markup
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Printf
+
+module Ast = CicNotationPt
+module Env = CicNotationEnv
+
+let debug = false
+let debug_print s = if debug then prerr_endline (Lazy.force s) else ()
+
+type pattern_id = int
+type pretty_printer_id = pattern_id
+
+let resolve_binder = function
+ | `Lambda -> "\\lambda"
+ | `Pi -> "\\Pi"
+ | `Forall -> "\\forall"
+ | `Exists -> "\\exists"
+
+let add_level_info prec assoc t = Ast.AttributedTerm (`Level (prec, assoc), t)
+let add_pos_info pos t = Ast.AttributedTerm (`ChildPos pos, t)
+let left_pos = add_pos_info `Left
+let right_pos = add_pos_info `Right
+let inner_pos = add_pos_info `Inner
+
+let rec top_pos t = add_level_info ~-1 Gramext.NonA (inner_pos t)
+(* function
+ | Ast.AttributedTerm (`Level _, t) ->
+ add_level_info ~-1 Gramext.NonA (inner_pos t)
+ | Ast.AttributedTerm (attr, t) -> Ast.AttributedTerm (attr, top_pos t)
+ | t -> add_level_info ~-1 Gramext.NonA (inner_pos t) *)
+
+let rec remove_level_info =
+ function
+ | Ast.AttributedTerm (`Level _, t) -> remove_level_info t
+ | Ast.AttributedTerm (a, t) -> Ast.AttributedTerm (a, remove_level_info t)
+ | t -> t
+
+let add_xml_attrs attrs t =
+ if attrs = [] then t else Ast.AttributedTerm (`XmlAttrs attrs, t)
+
+let add_keyword_attrs =
+ add_xml_attrs (RenderingAttrs.keyword_attributes `MathML)
+
+let box kind spacing indent content =
+ Ast.Layout (Ast.Box ((kind, spacing, indent), content))
+
+let hbox = box Ast.H
+let vbox = box Ast.V
+let hvbox = box Ast.HV
+let hovbox = box Ast.HOV
+let break = Ast.Layout Ast.Break
+let builtin_symbol s = Ast.Literal (`Symbol s)
+let keyword k = add_keyword_attrs (Ast.Literal (`Keyword k))
+
+let number s =
+ add_xml_attrs (RenderingAttrs.number_attributes `MathML)
+ (Ast.Literal (`Number s))
+
+let ident i =
+ add_xml_attrs (RenderingAttrs.ident_attributes `MathML) (Ast.Ident (i, None))
+
+let ident_w_href href i =
+ match href with
+ | None -> ident i
+ | Some href ->
+ let href = UriManager.string_of_uri href in
+ add_xml_attrs [Some "xlink", "href", href] (ident i)
+
+let binder_symbol s =
+ add_xml_attrs (RenderingAttrs.builtin_symbol_attributes `MathML)
+ (builtin_symbol s)
+
+let string_of_sort_kind = function
+ | `Prop -> "Prop"
+ | `Set -> "Set"
+ | `CProp -> "CProp"
+ | `Type _ -> "Type"
+
+let pp_ast0 t k =
+ let rec aux =
+ function
+ | Ast.Appl ts ->
+ let rec aux_args pos =
+ function
+ | [] -> []
+ | [ last ] ->
+ let last = k last in
+ if pos = `Left then [ left_pos last ] else [ right_pos last ]
+ | hd :: tl ->
+ (add_pos_info pos (k hd)) :: aux_args `Inner tl
+ in
+ add_level_info Ast.apply_prec Ast.apply_assoc
+ (hovbox true true (CicNotationUtil.dress break (aux_args `Left ts)))
+ | Ast.Binder (binder_kind, (id, ty), body) ->
+ add_level_info Ast.binder_prec Ast.binder_assoc
+ (hvbox false true
+ [ binder_symbol (resolve_binder binder_kind);
+ k id; builtin_symbol ":"; aux_ty ty; break;
+ builtin_symbol "."; right_pos (k body) ])
+ | Ast.Case (what, indty_opt, outty_opt, patterns) ->
+ let outty_box =
+ match outty_opt with
+ | None -> []
+ | Some outty ->
+ [ keyword "return"; break; remove_level_info (k outty)]
+ in
+ let indty_box =
+ match indty_opt with
+ | None -> []
+ | Some (indty, href) -> [ keyword "in"; break; ident_w_href href indty ]
+ in
+ let match_box =
+ hvbox false false [
+ hvbox false true [
+ hvbox false true [ keyword "match"; break; top_pos (k what) ];
+ break;
+ hvbox false true indty_box;
+ break;
+ hvbox false true outty_box
+ ];
+ break;
+ keyword "with"
+ ]
+ in
+ let mk_case_pattern (head, href, vars) =
+ hbox true false (ident_w_href href head :: List.map aux_var vars)
+ in
+ let patterns' =
+ List.map
+ (fun (lhs, rhs) ->
+ remove_level_info
+ (hvbox false true [
+ hbox false true [
+ mk_case_pattern lhs; builtin_symbol "\\Rightarrow" ];
+ break; top_pos (k rhs) ]))
+ patterns
+ in
+ let patterns'' =
+ let rec aux_patterns = function
+ | [] -> assert false
+ | [ last ] ->
+ [ break;
+ hbox false false [
+ builtin_symbol "|";
+ last; builtin_symbol "]" ] ]
+ | hd :: tl ->
+ [ break; hbox false false [ builtin_symbol "|"; hd ] ]
+ @ aux_patterns tl
+ in
+ match patterns' with
+ | [] ->
+ [ hbox false false [ builtin_symbol "["; builtin_symbol "]" ] ]
+ | [ one ] ->
+ [ hbox false false [
+ builtin_symbol "["; one; builtin_symbol "]" ] ]
+ | hd :: tl ->
+ hbox false false [ builtin_symbol "["; hd ]
+ :: aux_patterns tl
+ in
+ add_level_info Ast.simple_prec Ast.simple_assoc
+ (hvbox false false [
+ hvbox false false ([match_box]); break;
+ hbox false false [ hvbox false false patterns'' ] ])
+ | Ast.Cast (bo, ty) ->
+ add_level_info Ast.simple_prec Ast.simple_assoc
+ (hvbox false true [
+ builtin_symbol "("; top_pos (k bo); break; builtin_symbol ":";
+ top_pos (k ty); builtin_symbol ")"])
+ | Ast.LetIn (var, s, t) ->
+ add_level_info Ast.let_in_prec Ast.let_in_assoc
+ (hvbox false true [
+ hvbox false true [
+ keyword "let";
+ hvbox false true [
+ aux_var var; builtin_symbol "\\def"; break; top_pos (k s) ];
+ break; keyword "in" ];
+ break;
+ k t ])
+ | Ast.LetRec (rec_kind, funs, where) ->
+ let rec_op =
+ match rec_kind with `Inductive -> "rec" | `CoInductive -> "corec"
+ in
+ let mk_fun (var, body, _) = aux_var var, k body in
+ let mk_funs = List.map mk_fun in
+ let fst_fun, tl_funs =
+ match mk_funs funs with hd :: tl -> hd, tl | [] -> assert false
+ in
+ let fst_row =
+ let (name, body) = fst_fun in
+ hvbox false true [
+ keyword "let"; keyword rec_op; name; builtin_symbol "\\def"; break;
+ top_pos body ]
+ in
+ let tl_rows =
+ List.map
+ (fun (name, body) ->
+ [ break;
+ hvbox false true [
+ keyword "and"; name; builtin_symbol "\\def"; break; body ] ])
+ tl_funs
+ in
+ add_level_info Ast.let_in_prec Ast.let_in_assoc
+ ((hvbox false false
+ (fst_row :: List.flatten tl_rows
+ @ [ break; keyword "in"; break; k where ])))
+ | Ast.Implicit -> builtin_symbol "?"
+ | Ast.Meta (n, l) ->
+ let local_context l =
+ CicNotationUtil.dress (builtin_symbol ";")
+ (List.map (function None -> builtin_symbol "_" | Some t -> k t) l)
+ in
+ hbox false false
+ ([ builtin_symbol "?"; number (string_of_int n) ]
+ @ (if l <> [] then local_context l else []))
+ | Ast.Sort sort -> aux_sort sort
+ | Ast.Num _
+ | Ast.Symbol _
+ | Ast.Ident (_, None) | Ast.Ident (_, Some [])
+ | Ast.Uri (_, None) | Ast.Uri (_, Some [])
+ | Ast.Literal _
+ | Ast.UserInput as leaf -> leaf
+ | t -> CicNotationUtil.visit_ast ~special_k k t
+ and aux_sort sort_kind =
+ add_xml_attrs (RenderingAttrs.keyword_attributes `MathML)
+ (Ast.Ident (string_of_sort_kind sort_kind, None))
+ and aux_ty = function
+ | None -> builtin_symbol "?"
+ | Some ty -> k ty
+ and aux_var = function
+ | name, Some ty ->
+ hvbox false true [
+ builtin_symbol "("; name; builtin_symbol ":"; break; k ty;
+ builtin_symbol ")" ]
+ | name, None -> name
+ and special_k = function
+ | Ast.AttributedTerm (attrs, t) -> Ast.AttributedTerm (attrs, k t)
+ | t ->
+ prerr_endline ("unexpected special: " ^ CicNotationPp.pp_term t);
+ assert false
+ in
+ aux t
+
+ (* persistent state *)
+
+let level1_patterns21 = Hashtbl.create 211
+
+let compiled21 = ref None
+
+let pattern21_matrix = ref []
+
+let get_compiled21 () =
+ match !compiled21 with
+ | None -> assert false
+ | Some f -> Lazy.force f
+
+let set_compiled21 f = compiled21 := Some f
+
+let add_idrefs =
+ List.fold_right (fun idref t -> Ast.AttributedTerm (`IdRef idref, t))
+
+let instantiate21 idrefs env l1 =
+ let rec subst_singleton pos env =
+ function
+ Ast.AttributedTerm (attr, t) ->
+ Ast.AttributedTerm (attr, subst_singleton pos env t)
+ | t -> CicNotationUtil.group (subst pos env t)
+ and subst pos env = function
+ | Ast.AttributedTerm (attr, t) as term ->
+(* prerr_endline ("loosing attribute " ^ CicNotationPp.pp_attribute attr); *)
+ subst pos env t
+ | Ast.Variable var ->
+ let name, expected_ty = CicNotationEnv.declaration_of_var var in
+ let ty, value =
+ try
+ List.assoc name env
+ with Not_found ->
+ prerr_endline ("name " ^ name ^ " not found in environment");
+ assert false
+ in
+ assert (CicNotationEnv.well_typed ty value); (* INVARIANT *)
+ (* following assertion should be a conditional that makes this
+ * instantiation fail *)
+ assert (CicNotationEnv.well_typed expected_ty value);
+ [ add_pos_info pos (CicNotationEnv.term_of_value value) ]
+ | Ast.Magic m -> subst_magic pos env m
+ | Ast.Literal l as t ->
+ let t = add_idrefs idrefs t in
+ (match l with
+ | `Keyword k -> [ add_keyword_attrs t ]
+ | _ -> [ t ])
+ | Ast.Layout l -> [ Ast.Layout (subst_layout pos env l) ]
+ | t -> [ CicNotationUtil.visit_ast (subst_singleton pos env) t ]
+ and subst_magic pos env = function
+ | Ast.List0 (p, sep_opt)
+ | Ast.List1 (p, sep_opt) ->
+ let rec_decls = CicNotationEnv.declarations_of_term p in
+ let rec_values =
+ List.map (fun (n, _) -> CicNotationEnv.lookup_list env n) rec_decls
+ in
+ let values = CicNotationUtil.ncombine rec_values in
+ let sep =
+ match sep_opt with
+ | None -> []
+ | Some l -> [ Ast.Literal l ]
+ in
+ let rec instantiate_list acc = function
+ | [] -> List.rev acc
+ | value_set :: [] ->
+ let env = CicNotationEnv.combine rec_decls value_set in
+ instantiate_list (CicNotationUtil.group (subst pos env p) :: acc)
+ []
+ | value_set :: tl ->
+ let env = CicNotationEnv.combine rec_decls value_set in
+ let terms = subst pos env p in
+ instantiate_list (CicNotationUtil.group (terms @ sep) :: acc) tl
+ in
+ instantiate_list [] values
+ | Ast.Opt p ->
+ let opt_decls = CicNotationEnv.declarations_of_term p in
+ let env =
+ let rec build_env = function
+ | [] -> []
+ | (name, ty) :: tl ->
+ (* assumption: if one of the value is None then all are *)
+ (match CicNotationEnv.lookup_opt env name with
+ | None -> raise Exit
+ | Some v -> (name, (ty, v)) :: build_env tl)
+ in
+ try build_env opt_decls with Exit -> []
+ in
+ begin
+ match env with
+ | [] -> []
+ | _ -> subst pos env p
+ end
+ | _ -> assert false (* impossible *)
+ and subst_layout pos env = function
+ | Ast.Box (kind, tl) ->
+ let tl' = subst_children pos env tl in
+ Ast.Box (kind, List.concat tl')
+ | l -> CicNotationUtil.visit_layout (subst_singleton pos env) l
+ and subst_children pos env =
+ function
+ | [] -> []
+ | [ child ] ->
+ let pos' =
+ match pos with
+ | `Inner -> `Right
+ | `Left -> `Left
+(* | `None -> assert false *)
+ | `Right -> `Right
+ in
+ [ subst pos' env child ]
+ | hd :: tl ->
+ let pos' =
+ match pos with
+ | `Inner -> `Inner
+ | `Left -> `Inner
+(* | `None -> assert false *)
+ | `Right -> `Right
+ in
+ (subst pos env hd) :: subst_children pos' env tl
+ in
+ subst_singleton `Left env l1
+
+let rec pp_ast1 term =
+ let rec pp_value = function
+ | CicNotationEnv.NumValue _ as v -> v
+ | CicNotationEnv.StringValue _ as v -> v
+(* | CicNotationEnv.TermValue t when t == term -> CicNotationEnv.TermValue (pp_ast0 t pp_ast1) *)
+ | CicNotationEnv.TermValue t -> CicNotationEnv.TermValue (pp_ast1 t)
+ | CicNotationEnv.OptValue None as v -> v
+ | CicNotationEnv.OptValue (Some v) ->
+ CicNotationEnv.OptValue (Some (pp_value v))
+ | CicNotationEnv.ListValue vl ->
+ CicNotationEnv.ListValue (List.map pp_value vl)
+ in
+ let ast_env_of_env env =
+ List.map (fun (var, (ty, value)) -> (var, (ty, pp_value value))) env
+ in
+(* prerr_endline ("pattern matching from 2 to 1 on term " ^ CicNotationPp.pp_term term); *)
+ match term with
+ | Ast.AttributedTerm (attrs, term') ->
+ Ast.AttributedTerm (attrs, pp_ast1 term')
+ | _ ->
+ (match (get_compiled21 ()) term with
+ | None -> pp_ast0 term pp_ast1
+ | Some (env, ctors, pid) ->
+ let idrefs =
+ List.flatten (List.map CicNotationUtil.get_idrefs ctors)
+ in
+ let l1 =
+ try
+ Hashtbl.find level1_patterns21 pid
+ with Not_found -> assert false
+ in
+ instantiate21 idrefs (ast_env_of_env env) l1)
+
+let load_patterns21 t =
+ set_compiled21 (lazy (Content2presMatcher.Matcher21.compiler t))
+
+let pp_ast ast =
+ debug_print (lazy "pp_ast <-");
+ let ast' = pp_ast1 ast in
+ debug_print (lazy ("pp_ast -> " ^ CicNotationPp.pp_term ast'));
+ ast'
+
+exception Pretty_printer_not_found
+
+let fill_pos_info l1_pattern = l1_pattern
+(* let rec aux toplevel pos =
+ function
+ | Ast.Layout l ->
+ (match l
+
+ | Ast.Magic m ->
+ Ast.Box (
+ | Ast.Variable _ as t -> add_pos_info pos t
+ | t -> t
+ in
+ aux true l1_pattern *)
+
+let fresh_id =
+ let counter = ref ~-1 in
+ fun () ->
+ incr counter;
+ !counter
+
+let add_pretty_printer ~precedence ~associativity l2 l1 =
+ let id = fresh_id () in
+ let l1' = add_level_info precedence associativity (fill_pos_info l1) in
+ let l2' = CicNotationUtil.strip_attributes l2 in
+ Hashtbl.add level1_patterns21 id l1';
+ pattern21_matrix := (l2', id) :: !pattern21_matrix;
+ load_patterns21 !pattern21_matrix;
+ id
+
+let remove_pretty_printer id =
+ (try
+ Hashtbl.remove level1_patterns21 id;
+ with Not_found -> raise Pretty_printer_not_found);
+ pattern21_matrix := List.filter (fun (_, id') -> id <> id') !pattern21_matrix;
+ load_patterns21 !pattern21_matrix
+
+ (* presentation -> content *)
+
+let unopt_names names env =
+ let rec aux acc = function
+ | (name, (ty, v)) :: tl when List.mem name names ->
+ (match ty, v with
+ | Env.OptType ty, Env.OptValue (Some v) ->
+ aux ((name, (ty, v)) :: acc) tl
+ | _ -> assert false)
+ | hd :: tl -> aux (hd :: acc) tl
+ | [] -> acc
+ in
+ aux [] env
+
+let head_names names env =
+ let rec aux acc = function
+ | (name, (ty, v)) :: tl when List.mem name names ->
+ (match ty, v with
+ | Env.ListType ty, Env.ListValue (v :: _) ->
+ aux ((name, (ty, v)) :: acc) tl
+ | _ -> assert false)
+ | _ :: tl -> aux acc tl
+ (* base pattern may contain only meta names, thus we trash all others *)
+ | [] -> acc
+ in
+ aux [] env
+
+let tail_names names env =
+ let rec aux acc = function
+ | (name, (ty, v)) :: tl when List.mem name names ->
+ (match ty, v with
+ | Env.ListType ty, Env.ListValue (_ :: vtl) ->
+ aux ((name, (Env.ListType ty, Env.ListValue vtl)) :: acc) tl
+ | _ -> assert false)
+ | binding :: tl -> aux (binding :: acc) tl
+ | [] -> acc
+ in
+ aux [] env
+
+let instantiate_level2 env term =
+ let fresh_env = ref [] in
+ let lookup_fresh_name n =
+ try
+ List.assoc n !fresh_env
+ with Not_found ->
+ let new_name = CicNotationUtil.fresh_name () in
+ fresh_env := (n, new_name) :: !fresh_env;
+ new_name
+ in
+ let rec aux env term =
+(* prerr_endline ("ENV " ^ CicNotationPp.pp_env env); *)
+ match term with
+ | Ast.AttributedTerm (_, term) -> aux env term
+ | Ast.Appl terms -> Ast.Appl (List.map (aux env) terms)
+ | Ast.Binder (binder, var, body) ->
+ Ast.Binder (binder, aux_capture_var env var, aux env body)
+ | Ast.Case (term, indty, outty_opt, patterns) ->
+ Ast.Case (aux env term, indty, aux_opt env outty_opt,
+ List.map (aux_branch env) patterns)
+ | Ast.LetIn (var, t1, t2) ->
+ Ast.LetIn (aux_capture_var env var, aux env t1, aux env t2)
+ | Ast.LetRec (kind, definitions, body) ->
+ Ast.LetRec (kind, List.map (aux_definition env) definitions,
+ aux env body)
+ | Ast.Uri (name, None) -> Ast.Uri (name, None)
+ | Ast.Uri (name, Some substs) ->
+ Ast.Uri (name, Some (aux_substs env substs))
+ | Ast.Ident (name, Some substs) ->
+ Ast.Ident (name, Some (aux_substs env substs))
+ | Ast.Meta (index, substs) -> Ast.Meta (index, aux_meta_substs env substs)
+
+ | Ast.Implicit
+ | Ast.Ident _
+ | Ast.Num _
+ | Ast.Sort _
+ | Ast.Symbol _
+ | Ast.UserInput -> term
+
+ | Ast.Magic magic -> aux_magic env magic
+ | Ast.Variable var -> aux_variable env var
+
+ | _ -> assert false
+ and aux_opt env = function
+ | Some term -> Some (aux env term)
+ | None -> None
+ and aux_capture_var env (name, ty_opt) = (aux env name, aux_opt env ty_opt)
+ and aux_branch env (pattern, term) =
+ (aux_pattern env pattern, aux env term)
+ and aux_pattern env (head, hrefs, vars) =
+ (head, hrefs, List.map (aux_capture_var env) vars)
+ and aux_definition env (var, term, i) =
+ (aux_capture_var env var, aux env term, i)
+ and aux_substs env substs =
+ List.map (fun (name, term) -> (name, aux env term)) substs
+ and aux_meta_substs env meta_substs = List.map (aux_opt env) meta_substs
+ and aux_variable env = function
+ | Ast.NumVar name -> Ast.Num (Env.lookup_num env name, 0)
+ | Ast.IdentVar name -> Ast.Ident (Env.lookup_string env name, None)
+ | Ast.TermVar name -> Env.lookup_term env name
+ | Ast.FreshVar name -> Ast.Ident (lookup_fresh_name name, None)
+ | Ast.Ascription (term, name) -> assert false
+ and aux_magic env = function
+ | Ast.Default (some_pattern, none_pattern) ->
+ let some_pattern_names = CicNotationUtil.names_of_term some_pattern in
+ let none_pattern_names = CicNotationUtil.names_of_term none_pattern in
+ let opt_names =
+ List.filter
+ (fun name -> not (List.mem name none_pattern_names))
+ some_pattern_names
+ in
+ (match opt_names with
+ | [] -> assert false (* some pattern must contain at least 1 name *)
+ | (name :: _) as names ->
+ (match Env.lookup_value env name with
+ | Env.OptValue (Some _) ->
+ (* assumption: if "name" above is bound to Some _, then all
+ * names returned by "meta_names_of" are bound to Some _ as well
+ *)
+ aux (unopt_names names env) some_pattern
+ | Env.OptValue None -> aux env none_pattern
+ | _ ->
+ prerr_endline (sprintf
+ "lookup of %s in env %s did not return an optional value"
+ name (CicNotationPp.pp_env env));
+ assert false))
+ | Ast.Fold (`Left, base_pattern, names, rec_pattern) ->
+ let acc_name = List.hd names in (* names can't be empty, cfr. parser *)
+ let meta_names =
+ List.filter ((<>) acc_name)
+ (CicNotationUtil.names_of_term rec_pattern)
+ in
+ (match meta_names with
+ | [] -> assert false (* as above *)
+ | (name :: _) as names ->
+ let rec instantiate_fold_left acc env' =
+ match Env.lookup_value env' name with
+ | Env.ListValue (_ :: _) ->
+ instantiate_fold_left
+ (let acc_binding =
+ acc_name, (Env.TermType, Env.TermValue acc)
+ in
+ aux (acc_binding :: head_names names env') rec_pattern)
+ (tail_names names env')
+ | Env.ListValue [] -> acc
+ | _ -> assert false
+ in
+ instantiate_fold_left (aux env base_pattern) env)
+ | Ast.Fold (`Right, base_pattern, names, rec_pattern) ->
+ let acc_name = List.hd names in (* names can't be empty, cfr. parser *)
+ let meta_names =
+ List.filter ((<>) acc_name)
+ (CicNotationUtil.names_of_term rec_pattern)
+ in
+ (match meta_names with
+ | [] -> assert false (* as above *)
+ | (name :: _) as names ->
+ let rec instantiate_fold_right env' =
+ match Env.lookup_value env' name with
+ | Env.ListValue (_ :: _) ->
+ let acc = instantiate_fold_right (tail_names names env') in
+ let acc_binding =
+ acc_name, (Env.TermType, Env.TermValue acc)
+ in
+ aux (acc_binding :: head_names names env') rec_pattern
+ | Env.ListValue [] -> aux env base_pattern
+ | _ -> assert false
+ in
+ instantiate_fold_right env)
+ | Ast.If (_, p_true, p_false) as t ->
+ aux env (CicNotationUtil.find_branch (Ast.Magic t))
+ | Ast.Fail -> assert false
+ | _ -> assert false
+ in
+ aux env term
+
+ (* initialization *)
+
+let _ = load_patterns21 []
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+ (** {2 Persistant state handling} *)
+
+type pretty_printer_id
+
+val add_pretty_printer:
+ precedence:int ->
+ associativity:Gramext.g_assoc ->
+ CicNotationPt.term -> (* level 2 pattern *)
+ CicNotationPt.term -> (* level 1 pattern *)
+ pretty_printer_id
+
+exception Pretty_printer_not_found
+
+ (** @raise Pretty_printer_not_found *)
+val remove_pretty_printer: pretty_printer_id -> unit
+
+ (** {2 content -> pres} *)
+
+val pp_ast: CicNotationPt.term -> CicNotationPt.term
+
+ (** {2 pres -> content} *)
+
+ (** fills a term pattern instantiating variable magics *)
+val instantiate_level2:
+ CicNotationEnv.t -> CicNotationPt.term ->
+ CicNotationPt.term
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+let _ =
+ let level = ref "2@" in
+ let ic = ref stdin in
+ let arg_spec = [ "-level", Arg.Set_string level, "set the notation level" ] in
+ let usage = "test_lexer [ -level level ] [ file ]" in
+ let open_file fname =
+ if !ic <> stdin then close_in !ic;
+ ic := open_in fname
+ in
+ Arg.parse arg_spec open_file usage;
+ let lexer =
+ match !level with
+ "1" -> CicNotationLexer.level1_pattern_lexer
+ | "2@" -> CicNotationLexer.level2_ast_lexer
+ | "2$" -> CicNotationLexer.level2_meta_lexer
+ | l ->
+ prerr_endline (Printf.sprintf "Unsupported level %s" l);
+ exit 2
+ in
+ let token_stream =
+ fst (lexer.Token.tok_func (Obj.magic (Ulexing.from_utf8_channel !ic)))
+ in
+ Printf.printf "Lexing notation level %s\n" !level; flush stdout;
+ let rec dump () =
+ let (a,b) = Stream.next token_stream in
+ if a = "EOI" then raise Stream.Failure;
+ print_endline (Printf.sprintf "%s '%s'" a b);
+ dump ()
+ in
+ try
+ dump ()
+ with Stream.Failure -> ()
+
hExtlib.cmo: hExtlib.cmi
hExtlib.cmx: hExtlib.cmi
+patternMatcher.cmo: patternMatcher.cmi
+patternMatcher.cmx: patternMatcher.cmi
PACKAGE = extlib
PREDICATES =
-INTERFACE_FILES = \
- hExtlib.mli
+INTERFACE_FILES = \
+ hExtlib.mli \
+ patternMatcher.mli \
+ $(NULL)
IMPLEMENTATION_FILES = \
$(INTERFACE_FILES:%.mli=%.ml)
EXTRA_OBJECTS_TO_INSTALL =
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Printf
+
+type pattern_kind = Variable | Constructor
+type tag_t = int
+
+type pattern_id = int
+
+module OrderedInt =
+struct
+ type t = int
+ let compare (x1:t) (x2:t) = Pervasives.compare x2 x1 (* reverse order *)
+end
+
+module IntSet = Set.Make (OrderedInt)
+
+let int_set_of_int_list l =
+ List.fold_left (fun acc i -> IntSet.add i acc) IntSet.empty l
+
+module type PATTERN =
+sig
+ type pattern_t
+ type term_t
+ val classify : pattern_t -> pattern_kind
+ val tag_of_pattern : pattern_t -> tag_t * pattern_t list
+ val tag_of_term : term_t -> tag_t * term_t list
+ val string_of_term: term_t -> string
+ val string_of_pattern: pattern_t -> string
+end
+
+module Matcher (P: PATTERN) =
+struct
+ type row_t = P.pattern_t list * P.pattern_t list * pattern_id
+ type t = row_t list
+
+ let compatible p1 p2 = P.classify p1 = P.classify p2
+
+ let matched = List.map (fun (matched, _, pid) -> matched, pid)
+
+ let partition t pidl =
+ let partitions = Hashtbl.create 11 in
+ let add pid row = Hashtbl.add partitions pid row in
+ (try
+ List.iter2 add pidl t
+ with Invalid_argument _ -> assert false);
+ let pidset = int_set_of_int_list pidl in
+ IntSet.fold
+ (fun pid acc ->
+ match Hashtbl.find_all partitions pid with
+ | [] -> acc
+ | patterns -> (pid, List.rev patterns) :: acc)
+ pidset []
+
+ let are_empty t =
+ match t with
+ | (_, [], _) :: _ -> true
+ (* if first row has an empty list of patterns, then others have as well *)
+ | _ -> false
+
+ (* return 2 lists of rows, first one containing homogeneous rows according
+ * to "compatible" below *)
+ let horizontal_split t =
+ let ap, first_row, t', first_row_class =
+ match t with
+ | [] -> assert false
+ | (_, [], _) :: _ ->
+ assert false (* are_empty should have been invoked in advance *)
+ | ((_, hd :: _ , _) as row) :: tl -> hd, row, tl, P.classify hd
+ in
+ let rec aux prev_t = function
+ | [] -> List.rev prev_t, []
+ | (_, [], _) :: _ -> assert false
+ | ((_, hd :: _, _) as row) :: tl when compatible ap hd ->
+ aux (row :: prev_t) tl
+ | t -> List.rev prev_t, t
+ in
+ let rows1, rows2 = aux [first_row] t' in
+ first_row_class, rows1, rows2
+
+ (* return 2 lists, first one representing first column, second one
+ * representing a new pattern matrix where matched patterns have been moved
+ * to decl *)
+ let vertical_split t =
+ List.map
+ (function
+ | decls, hd :: tl, pid -> hd :: decls, tl, pid
+ | _ -> assert false)
+ t
+
+ let variable_closure ksucc =
+ (fun matched_terms constructors terms ->
+(* prerr_endline "variable_closure"; *)
+ match terms with
+ | hd :: tl -> ksucc (hd :: matched_terms) constructors tl
+ | _ -> assert false)
+
+ let success_closure ksucc =
+ (fun matched_terms constructors terms ->
+(* prerr_endline "success_closure"; *)
+ ksucc matched_terms constructors)
+
+ let constructor_closure ksuccs =
+ (fun matched_terms constructors terms ->
+(* prerr_endline "constructor_closure"; *)
+ match terms with
+ | t :: tl ->
+ (try
+ let tag, subterms = P.tag_of_term t in
+ let constructors' =
+ if subterms = [] then t :: constructors else constructors
+ in
+ let k' = List.assoc tag ksuccs in
+ k' matched_terms constructors' (subterms @ tl)
+ with Not_found -> None)
+ | [] -> assert false)
+
+ let backtrack_closure ksucc kfail =
+ (fun matched_terms constructors terms ->
+(* prerr_endline "backtrack_closure"; *)
+ match ksucc matched_terms constructors terms with
+ | Some x -> Some x
+ | None -> kfail matched_terms constructors terms)
+
+ let compiler rows match_cb fail_k =
+ let rec aux t =
+ if t = [] then
+ (fun _ _ _ -> fail_k ())
+ else if are_empty t then
+ success_closure (match_cb (matched t))
+ else
+ match horizontal_split t with
+ | _, [], _ -> assert false
+ | Variable, t', [] -> variable_closure (aux (vertical_split t'))
+ | Constructor, t', [] ->
+ let tagl =
+ List.map
+ (function
+ | _, p :: _, _ -> fst (P.tag_of_pattern p)
+ | _ -> assert false)
+ t'
+ in
+ let clusters = partition t' tagl in
+ let ksuccs =
+ List.map
+ (fun (tag, cluster) ->
+ let cluster' =
+ List.map (* add args as patterns heads *)
+ (function
+ | matched_p, p :: tl, pid ->
+ let _, subpatterns = P.tag_of_pattern p in
+ matched_p, subpatterns @ tl, pid
+ | _ -> assert false)
+ cluster
+ in
+ tag, aux cluster')
+ clusters
+ in
+ constructor_closure ksuccs
+ | _, t', t'' -> backtrack_closure (aux t') (aux t'')
+ in
+ let t = List.map (fun (p, pid) -> [], [p], pid) rows in
+ let matcher = aux t in
+ (fun term -> matcher [] [] [term])
+end
+
--- /dev/null
+
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+type pattern_kind = Variable | Constructor
+type tag_t = int
+
+module type PATTERN =
+sig
+ type pattern_t
+ type term_t
+
+ val classify : pattern_t -> pattern_kind
+ val tag_of_pattern : pattern_t -> tag_t * pattern_t list
+ val tag_of_term : term_t -> tag_t * term_t list
+
+ (** {3 Debugging} *)
+ val string_of_term: term_t -> string
+ val string_of_pattern: pattern_t -> string
+end
+
+module Matcher (P: PATTERN) :
+sig
+ (** @param patterns pattern matrix (pairs <pattern, pattern_id>)
+ * @param success_cb callback invoked in case of matching.
+ * Its argument are the list of pattern who matches the input term, the list
+ * of terms bound in them, the list of terms which matched constructors.
+ * Its return value is Some _ if the matching is valid, None otherwise; the
+ * latter kind of return value will trigger backtracking in the pattern
+ * matching algorithm
+ * @param failure_cb callback invoked in case of matching failure
+ * @param term term on which pattern match on *)
+ val compiler:
+ (P.pattern_t * int) list ->
+ ((P.pattern_t list * int) list -> P.term_t list -> P.term_t list ->
+ 'a option) -> (* terms *) (* constructors *)
+ (unit -> 'a option) ->
+ (P.term_t -> 'a option)
+end
+
--- /dev/null
+*.cm[iaox]
+*.cmxa
+test_dep
+test_parser
+print_grammar
--- /dev/null
+grafiteAstPp.cmi: grafiteAst.cmo
+grafiteParser.cmi: grafiteAst.cmo
+cicNotation.cmi: grafiteAst.cmo
+grafiteAstPp.cmo: grafiteAst.cmo grafiteAstPp.cmi
+grafiteAstPp.cmx: grafiteAst.cmx grafiteAstPp.cmi
+grafiteParser.cmo: grafiteAst.cmo grafiteParser.cmi
+grafiteParser.cmx: grafiteAst.cmx grafiteParser.cmi
+cicNotation.cmo: grafiteParser.cmi grafiteAst.cmo cicNotation.cmi
+cicNotation.cmx: grafiteParser.cmx grafiteAst.cmx cicNotation.cmi
--- /dev/null
+PACKAGE = grafite
+PREDICATES =
+
+INTERFACE_FILES = \
+ grafiteAstPp.mli \
+ grafiteParser.mli \
+ cicNotation.mli \
+ $(NULL)
+IMPLEMENTATION_FILES = \
+ grafiteAst.ml \
+ $(INTERFACE_FILES:%.mli=%.ml)
+
+all: test_parser print_grammar test_dep
+clean: clean_tests
+
+grafiteParser.cmo: OCAMLC = $(OCAMLC_P4)
+grafiteParser.cmx: OCAMLOPT = $(OCAMLOPT_P4)
+
+clean_tests:
+ rm -f test_parser{,.opt} test_dep{,.opt} print_grammar{,.opt}
+
+LOCAL_LINKOPTS = -package helm-grafite -linkpkg
+test: test_parser print_grammar test_dep
+test_parser: test_parser.ml $(PACKAGE).cma
+ $(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
+print_grammar: print_grammar.ml $(PACKAGE).cma
+ $(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
+test_dep: test_dep.ml $(PACKAGE).cma
+ $(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
+
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open GrafiteAst
+
+type notation_id =
+ | RuleId of CicNotationParser.rule_id
+ | InterpretationId of TermAcicContent.interpretation_id
+ | PrettyPrinterId of TermContentPres.pretty_printer_id
+
+let process_notation st =
+ match st with
+ | Notation (loc, dir, l1, associativity, precedence, l2) ->
+ let rule_id =
+ if dir <> Some `RightToLeft then
+ [ RuleId (CicNotationParser.extend l1 ?precedence ?associativity
+ (fun env loc -> TermContentPres.instantiate_level2 env l2)) ]
+ else
+ []
+ in
+ let pp_id =
+ if dir <> Some `LeftToRight then
+ [ PrettyPrinterId
+ (TermContentPres.add_pretty_printer ?precedence ?associativity
+ l2 l1) ]
+ else
+ []
+ in
+ st, rule_id @ pp_id
+ | Interpretation (loc, dsc, l2, l3) ->
+ let interp_id = TermAcicContent.add_interpretation dsc l2 l3 in
+ st, [ InterpretationId interp_id ]
+ | st -> st, []
+
+let remove_notation = function
+ | RuleId id -> CicNotationParser.delete id
+ | PrettyPrinterId id -> TermContentPres.remove_pretty_printer id
+ | InterpretationId id -> TermAcicContent.remove_interpretation id
+
+let load_notation fname =
+ let ic = open_in fname in
+ let lexbuf = Ulexing.from_utf8_channel ic in
+ try
+ while true do
+ match GrafiteParser.parse_statement lexbuf with
+ | Executable (_, Command (_, cmd)) -> ignore (process_notation cmd)
+ | _ -> ()
+ done
+ with End_of_file -> close_in ic
+
+let get_all_notations () =
+ List.map
+ (fun (interp_id, dsc) ->
+ InterpretationId interp_id, "interpretation: " ^ dsc)
+ (TermAcicContent.get_all_interpretations ())
+
+let get_active_notations () =
+ List.map (fun id -> InterpretationId id)
+ (TermAcicContent.get_active_interpretations ())
+
+let set_active_notations ids =
+ let interp_ids =
+ HExtlib.filter_map
+ (function InterpretationId interp_id -> Some interp_id | _ -> None)
+ ids
+ in
+ TermAcicContent.set_active_interpretations interp_ids
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+type notation_id
+
+val process_notation:
+ ('a, 'b) GrafiteAst.command -> ('a, 'b) GrafiteAst.command * notation_id list
+
+val remove_notation: notation_id -> unit
+
+(** @param fname file from which load notation *)
+val load_notation: string -> unit
+
+(** {2 Notation enabling/disabling}
+ * Right now, only disabling of notation during pretty printing is supporting.
+ * If it is useful to disable it also for the input phase is still to be
+ * understood ... *)
+
+val get_all_notations: unit -> (notation_id * string) list (* id, dsc *)
+val get_active_notations: unit -> notation_id list
+val set_active_notations: notation_id list -> unit
+
--- /dev/null
+(* Copyright (C) 2004, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+module Ast = CicNotationPt
+
+type direction = [ `LeftToRight | `RightToLeft ]
+
+type loc = Ast.location
+
+type ('term, 'lazy_term, 'ident) pattern =
+ 'lazy_term option * ('ident * 'term) list * 'term
+
+type ('term, 'ident) type_spec =
+ | Ident of 'ident
+ | Type of UriManager.uri * int
+
+type reduction =
+ [ `Normalize
+ | `Reduce
+ | `Simpl
+ | `Unfold of CicNotationPt.term option
+ | `Whd ]
+
+type ('term, 'lazy_term, 'reduction, 'ident) tactic =
+ | Absurd of loc * 'term
+ | Apply of loc * 'term
+ | Assumption of loc
+ | Auto of loc * int option * int option * string option * string option
+ (* depth, width, paramodulation, full *) (* ALB *)
+ | Change of loc * ('term, 'lazy_term, 'ident) pattern * 'lazy_term
+ | Clear of loc * 'ident
+ | ClearBody of loc * 'ident
+ | Compare of loc * 'term
+ | Constructor of loc * int
+ | Contradiction of loc
+ | Cut of loc * 'ident option * 'term
+ | DecideEquality of loc
+ | Decompose of loc * ('term, 'ident) type_spec list * 'ident * 'ident list
+ | Discriminate of loc * 'term
+ | Elim of loc * 'term * 'term option * int option * 'ident list
+ | ElimType of loc * 'term * 'term option * int option * 'ident list
+ | Exact of loc * 'term
+ | Exists of loc
+ | Fail of loc
+ | Fold of loc * 'reduction * 'lazy_term * ('term, 'lazy_term, 'ident) pattern
+ | Fourier of loc
+ | FwdSimpl of loc * string * 'ident list
+ | Generalize of loc * ('term, 'lazy_term, 'ident) pattern * 'ident option
+ | Goal of loc * int (* change current goal, argument is goal number 1-based *)
+ | IdTac of loc
+ | Injection of loc * 'term
+ | Intros of loc * int option * 'ident list
+ | LApply of loc * int option * 'term list * 'term * 'ident option
+ | Left of loc
+ | LetIn of loc * 'term * 'ident
+ | Reduce of loc * 'reduction * ('term, 'lazy_term, 'ident) pattern
+ | Reflexivity of loc
+ | Replace of loc * ('term, 'lazy_term, 'ident) pattern * 'lazy_term
+ | Rewrite of loc * direction * 'term *
+ ('term, 'lazy_term, 'ident) pattern
+ | Right of loc
+ | Ring of loc
+ | Split of loc
+ | Symmetry of loc
+ | Transitivity of loc * 'term
+
+type search_kind = [ `Locate | `Hint | `Match | `Elim ]
+
+type print_kind = [ `Env | `Coer ]
+
+type 'term macro =
+ (* Whelp's stuff *)
+ | WHint of loc * 'term
+ | WMatch of loc * 'term
+ | WInstance of loc * 'term
+ | WLocate of loc * string
+ | WElim of loc * 'term
+ (* real macros *)
+(* | Abort of loc *)
+ | Print of loc * string
+ | Check of loc * 'term
+ | Hint of loc
+ | Quit of loc
+(* | Redo of loc * int option
+ | Undo of loc * int option *)
+(* | Print of loc * print_kind *)
+ | Search_pat of loc * search_kind * string (* searches with string pattern *)
+ | Search_term of loc * search_kind * 'term (* searches with term pattern *)
+
+type alias_spec =
+ | Ident_alias of string * string (* identifier, uri *)
+ | Symbol_alias of string * int * string (* name, instance no, description *)
+ | Number_alias of int * string (* instance no, description *)
+
+type metadata =
+ | Dependency of string (* baseuri without trailing slash *)
+ | Baseuri of string
+
+let compare_metadata = Pervasives.compare
+
+let eq_metadata = (=)
+
+(** To be increased each time the command type below changes, used for "safe"
+ * marshalling *)
+let magic = 2
+
+type ('term,'obj) command =
+ | Default of loc * string * UriManager.uri list
+ | Include of loc * string
+ | Set of loc * string * string
+ | Drop of loc
+ | Qed of loc
+ (** name.
+ * Name is needed when theorem was started without providing a name
+ *)
+ | Coercion of loc * 'term
+ | Alias of loc * alias_spec
+ (** parameters, name, type, fields *)
+ | Obj of loc * 'obj
+ | Notation of loc * direction option * Ast.term * Gramext.g_assoc *
+ int * Ast.term
+ (* direction, l1 pattern, associativity, precedence, l2 pattern *)
+ | Interpretation of loc *
+ string * (string * Ast.argument_pattern list) *
+ Ast.cic_appl_pattern
+ (* description (i.e. id), symbol, arg pattern, appl pattern *)
+
+ | Metadata of loc * metadata
+
+ (* DEBUGGING *)
+ | Dump of loc (* dump grammar on stdout *)
+ (* DEBUGGING *)
+ | Render of loc * UriManager.uri (* render library object *)
+
+(* composed magic: term + command magics. No need to change this value *)
+let magic = magic + 10000 * CicNotationPt.magic
+
+let reash_cmd_uris =
+ let reash_uri uri = UriManager.uri_of_string (UriManager.string_of_uri uri) in
+ function
+ | Default (loc, name, uris) ->
+ let uris = List.map reash_uri uris in
+ Default (loc, name, uris)
+ | Interpretation (loc, dsc, args, cic_appl_pattern) ->
+ let rec aux =
+ function
+ | CicNotationPt.UriPattern uri ->
+ CicNotationPt.UriPattern (reash_uri uri)
+ | CicNotationPt.ApplPattern args ->
+ CicNotationPt.ApplPattern (List.map aux args)
+ | CicNotationPt.VarPattern _
+ | CicNotationPt.ImplicitPattern as pat -> pat
+ in
+ let appl_pattern = aux cic_appl_pattern in
+ Interpretation (loc, dsc, args, appl_pattern)
+ | cmd -> cmd
+
+type ('term, 'lazy_term, 'reduction, 'ident) tactical =
+ | Tactic of loc * ('term, 'lazy_term, 'reduction, 'ident) tactic
+ | Do of loc * int * ('term, 'lazy_term, 'reduction, 'ident) tactical
+ | Repeat of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical
+ | Seq of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list
+ (* sequential composition *)
+ | Then of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical *
+ ('term, 'lazy_term, 'reduction, 'ident) tactical list
+ | First of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list
+ (* try a sequence of loc * tactical until one succeeds, fail otherwise *)
+ | Try of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical
+ (* try a tactical and mask failures *)
+ | Solve of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list
+
+ | Dot of loc
+ | Semicolon of loc
+ | Branch of loc
+ | Shift of loc
+ | Pos of loc * int
+ | Merge of loc
+ | Focus of loc * int list
+ | Unfocus of loc
+ | Skip of loc
+
+let is_punctuation =
+ function
+ | Dot _ | Semicolon _ | Branch _ | Shift _ | Merge _ | Pos _ -> true
+ | _ -> false
+
+type ('term, 'lazy_term, 'reduction, 'obj, 'ident) code =
+ | Command of loc * ('term,'obj) command
+ | Macro of loc * 'term macro
+ | Tactical of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical
+ * ('term, 'lazy_term, 'reduction, 'ident) tactical option(* punctuation *)
+
+type ('term, 'lazy_term, 'reduction, 'obj, 'ident) comment =
+ | Note of loc * string
+ | Code of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) code
+
+type ('term, 'lazy_term, 'reduction, 'obj, 'ident) statement =
+ | Executable of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) code
+ | Comment of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) comment
+
+ (* statements meaningful for matitadep *)
+type dependency =
+ | IncludeDep of string
+ | BaseuriDep of string
+ | UriDep of UriManager.uri
+
--- /dev/null
+(* Copyright (C) 2004, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Printf
+
+open GrafiteAst
+
+module Ast = CicNotationPt
+
+let tactical_terminator = ""
+let tactic_terminator = tactical_terminator
+let command_terminator = tactical_terminator
+
+let pp_term_ast term = CicNotationPp.pp_term term
+let pp_term_cic term = CicPp.ppterm term
+
+let pp_idents idents = "[" ^ String.concat "; " idents ^ "]"
+
+let pp_terms_ast terms = String.concat ", " (List.map pp_term_ast terms)
+
+let pp_reduction_kind = function
+ | `Normalize -> "normalize"
+ | `Reduce -> "reduce"
+ | `Simpl -> "simplify"
+ | `Unfold (Some t) -> "unfold " ^ pp_term_ast t
+ | `Unfold None -> "unfold"
+ | `Whd -> "whd"
+
+
+let pp_pattern (t, hyp, goal) =
+ let pp_hyp_pattern l =
+ String.concat "; "
+ (List.map (fun (name, p) -> sprintf "%s : %s" name (pp_term_ast p)) l) in
+ let pp_t t =
+ match t with
+ None -> ""
+ | Some t -> pp_term_ast t
+ in
+ pp_t t ^ " in " ^ pp_hyp_pattern hyp ^ " \\vdash " ^ pp_term_ast goal
+
+let pp_intros_specs = function
+ | None, [] -> ""
+ | Some num, [] -> Printf.sprintf " names %i" num
+ | None, idents -> Printf.sprintf " names %s" (pp_idents idents)
+ | Some num, idents -> Printf.sprintf " names %i %s" num (pp_idents idents)
+
+let rec pp_tactic = function
+ | Absurd (_, term) -> "absurd" ^ pp_term_ast term
+ | Apply (_, term) -> "apply " ^ pp_term_ast term
+ | Auto _ -> "auto"
+ | Assumption _ -> "assumption"
+ | Change (_, where, with_what) ->
+ sprintf "change %s with %s" (pp_pattern where) (pp_term_ast with_what)
+ | Clear (_,id) -> sprintf "clear %s" id
+ | ClearBody (_,id) -> sprintf "clearbody %s" id
+ | Compare (_,term) -> "compare " ^ pp_term_ast term
+ | Constructor (_,n) -> "constructor " ^ string_of_int n
+ | Contradiction _ -> "contradiction"
+ | Cut (_, ident, term) ->
+ "cut " ^ pp_term_ast term ^
+ (match ident with None -> "" | Some id -> " as " ^ id)
+ | DecideEquality _ -> "decide equality"
+ | Decompose (_, [], what, names) ->
+ sprintf "decompose %s%s" what (pp_intros_specs (None, names))
+ | Decompose (_, types, what, names) ->
+ let to_ident = function
+ | Ident id -> id
+ | Type _ -> assert false
+ in
+ let types = List.rev_map to_ident types in
+ sprintf "decompose %s %s%s" (pp_idents types) what (pp_intros_specs (None, names))
+ | Discriminate (_, term) -> "discriminate " ^ pp_term_ast term
+ | Elim (_, term, using, num, idents) ->
+ sprintf "elim " ^ pp_term_ast term ^
+ (match using with None -> "" | Some term -> " using " ^ pp_term_ast term)
+ ^ pp_intros_specs (num, idents)
+ | ElimType (_, term, using, num, idents) ->
+ sprintf "elim type " ^ pp_term_ast term ^
+ (match using with None -> "" | Some term -> " using " ^ pp_term_ast term)
+ ^ pp_intros_specs (num, idents)
+ | Exact (_, term) -> "exact " ^ pp_term_ast term
+ | Exists _ -> "exists"
+ | Fold (_, kind, term, pattern) ->
+ sprintf "fold %s %s %s" (pp_reduction_kind kind)
+ (pp_term_ast term) (pp_pattern pattern)
+ | FwdSimpl (_, hyp, idents) ->
+ sprintf "fwd %s%s" hyp
+ (match idents with [] -> "" | idents -> " " ^ pp_idents idents)
+ | Generalize (_, pattern, ident) ->
+ sprintf "generalize %s%s" (pp_pattern pattern)
+ (match ident with None -> "" | Some id -> " as " ^ id)
+ | Goal (_, n) -> "goal " ^ string_of_int n
+ | Fail _ -> "fail"
+ | Fourier _ -> "fourier"
+ | IdTac _ -> "id"
+ | Injection (_, term) -> "injection " ^ pp_term_ast term
+ | Intros (_, None, []) -> "intro"
+ | Intros (_, num, idents) ->
+ sprintf "intros%s%s"
+ (match num with None -> "" | Some num -> " " ^ string_of_int num)
+ (match idents with [] -> "" | idents -> " " ^ pp_idents idents)
+ | LApply (_, level_opt, terms, term, ident_opt) ->
+ sprintf "lapply %s%s%s%s"
+ (match level_opt with None -> "" | Some i -> " depth = " ^ string_of_int i ^ " ")
+ (pp_term_ast term)
+ (match terms with [] -> "" | _ -> " to " ^ pp_terms_ast terms)
+ (match ident_opt with None -> "" | Some ident -> " using " ^ ident)
+ | Left _ -> "left"
+ | LetIn (_, term, ident) -> sprintf "let %s in %s" (pp_term_ast term) ident
+ | Reduce (_, kind, pat) ->
+ sprintf "%s %s" (pp_reduction_kind kind) (pp_pattern pat)
+ | Reflexivity _ -> "reflexivity"
+ | Replace (_, pattern, t) ->
+ sprintf "replace %s with %s" (pp_pattern pattern) (pp_term_ast t)
+ | Rewrite (_, pos, t, pattern) ->
+ sprintf "rewrite %s %s %s"
+ (if pos = `LeftToRight then ">" else "<")
+ (pp_term_ast t)
+ (pp_pattern pattern)
+ | Right _ -> "right"
+ | Ring _ -> "ring"
+ | Split _ -> "split"
+ | Symmetry _ -> "symmetry"
+ | Transitivity (_, term) -> "transitivity " ^ pp_term_ast term
+
+let pp_search_kind = function
+ | `Locate -> "locate"
+ | `Hint -> "hint"
+ | `Match -> "match"
+ | `Elim -> "elim"
+ | `Instance -> "instance"
+
+let pp_macro pp_term = function
+ (* Whelp *)
+ | WInstance (_, term) -> "whelp instance " ^ pp_term term
+ | WHint (_, t) -> "whelp hint " ^ pp_term t
+ | WLocate (_, s) -> "whelp locate " ^ s
+ | WElim (_, t) -> "whelp elim " ^ pp_term t
+ | WMatch (_, term) -> "whelp match " ^ pp_term term
+ (* real macros *)
+(* | Abort _ -> "Abort" *)
+ | Check (_, term) -> sprintf "Check %s" (pp_term term)
+ | Hint _ -> "hint"
+(* | Redo (_, None) -> "Redo"
+ | Redo (_, Some n) -> sprintf "Redo %d" n *)
+ | Search_pat (_, kind, pat) ->
+ sprintf "search %s \"%s\"" (pp_search_kind kind) pat
+ | Search_term (_, kind, term) ->
+ sprintf "search %s %s" (pp_search_kind kind) (pp_term term)
+(* | Undo (_, None) -> "Undo"
+ | Undo (_, Some n) -> sprintf "Undo %d" n *)
+ | Print (_, name) -> sprintf "Print \"%s\"" name
+ | Quit _ -> "Quit"
+
+let pp_macro_ast = pp_macro pp_term_ast
+let pp_macro_cic = pp_macro pp_term_cic
+
+let pp_alias = function
+ | Ident_alias (id, uri) -> sprintf "alias id \"%s\" = \"%s\"" id uri
+ | Symbol_alias (symb, instance, desc) ->
+ sprintf "alias symbol \"%s\" (instance %d) = \"%s\""
+ symb instance desc
+ | Number_alias (instance,desc) ->
+ sprintf "alias num (instance %d) = \"%s\"" instance desc
+
+let pp_argument_pattern = function
+ | Ast.IdentArg (eta_depth, name) ->
+ let eta_buf = Buffer.create 5 in
+ for i = 1 to eta_depth do
+ Buffer.add_string eta_buf "\\eta."
+ done;
+ sprintf "%s%s" (Buffer.contents eta_buf) name
+
+let pp_l1_pattern = CicNotationPp.pp_term
+let pp_l2_pattern = CicNotationPp.pp_term
+
+let pp_associativity = function
+ | Gramext.LeftA -> "left associative"
+ | Gramext.RightA -> "right associative"
+ | Gramext.NonA -> "non associative"
+
+let pp_precedence i = sprintf "with precedence %d" i
+
+let pp_dir_opt = function
+ | None -> ""
+ | Some `LeftToRight -> "> "
+ | Some `RightToLeft -> "< "
+
+let pp_metadata =
+ function
+ | Dependency buri -> sprintf "dependency %s" buri
+ | Baseuri buri -> sprintf "baseuri %s" buri
+
+let pp_command = function
+ | Include (_,path) -> "include " ^ path
+ | Qed _ -> "qed"
+ | Drop _ -> "drop"
+ | Set (_, name, value) -> sprintf "set \"%s\" \"%s\"" name value
+ | Coercion (_,term) -> sprintf "coercion %s" (pp_term_ast term)
+ | Alias (_,s) -> pp_alias s
+ | Obj (_,obj) -> CicNotationPp.pp_obj obj
+ | Default (_,what,uris) ->
+ sprintf "default \"%s\" %s" what
+ (String.concat " " (List.map UriManager.string_of_uri uris))
+ | Interpretation (_, dsc, (symbol, arg_patterns), cic_appl_pattern) ->
+ sprintf "interpretation \"%s\" '%s %s = %s"
+ dsc symbol
+ (String.concat " " (List.map pp_argument_pattern arg_patterns))
+ (CicNotationPp.pp_cic_appl_pattern cic_appl_pattern)
+ | Notation (_, dir_opt, l1_pattern, assoc, prec, l2_pattern) ->
+ sprintf "notation %s\"%s\" %s %s for %s"
+ (pp_dir_opt dir_opt)
+ (pp_l1_pattern l1_pattern)
+ (pp_associativity assoc)
+ (pp_precedence prec)
+ (pp_l2_pattern l2_pattern)
+ | Metadata (_, m) -> sprintf "metadata %s" (pp_metadata m)
+ | Render _
+ | Dump _ -> assert false (* ZACK: debugging *)
+
+let rec pp_tactical = function
+ | Tactic (_, tac) -> pp_tactic tac
+ | Do (_, count, tac) -> sprintf "do %d %s" count (pp_tactical tac)
+ | Repeat (_, tac) -> "repeat " ^ pp_tactical tac
+ | Seq (_, tacs) -> pp_tacticals ~sep:"; " tacs
+ | Then (_, tac, tacs) ->
+ sprintf "%s; [%s]" (pp_tactical tac) (pp_tacticals ~sep:" | " tacs)
+ | First (_, tacs) -> sprintf "tries [%s]" (pp_tacticals ~sep:" | " tacs)
+ | Try (_, tac) -> "try " ^ pp_tactical tac
+ | Solve (_, tac) -> sprintf "solve [%s]" (pp_tacticals ~sep:" | " tac)
+
+ | Dot _ -> "."
+ | Semicolon _ -> ";"
+ | Branch _ -> "["
+ | Shift _ -> "|"
+ | Pos (_, i) -> sprintf "%d:" i
+ | Merge _ -> "]"
+ | Focus (_, goals) ->
+ sprintf "focus %s" (String.concat " " (List.map string_of_int goals))
+ | Unfocus _ -> "unfocus"
+ | Skip _ -> "skip"
+
+and pp_tacticals ~sep tacs = String.concat sep (List.map pp_tactical tacs)
+
+let pp_tactical tac = pp_tactical tac
+let pp_tactic tac = pp_tactic tac
+let pp_command tac = pp_command tac
+
+let pp_executable = function
+ | Macro (_,x) -> pp_macro_ast x
+ | Tactical (_, tac, Some punct) -> pp_tactical tac ^ pp_tactical punct
+ | Tactical (_, tac, None) -> pp_tactical tac
+ | Command (_,x) -> pp_command x
+
+let pp_comment = function
+ | Note (_,str) -> sprintf "(* %s *)" str
+ | Code (_,code) -> sprintf "(** %s. **)" (pp_executable code)
+
+let pp_statement = function
+ | Executable (_, ex) -> pp_executable ex
+ | Comment (_, c) -> pp_comment c
+
+let pp_cic_command = function
+ | Include (_,path) -> "include " ^ path
+ | Qed _ -> "qed"
+ | Drop _ -> "drop"
+ | Coercion (_,term) -> sprintf "coercion %s" (CicPp.ppterm term)
+ | Set _
+ | Alias _
+ | Default _
+ | Render _
+ | Dump _
+ | Interpretation _
+ | Metadata _
+ | Notation _
+ | Obj _ -> assert false (* not implemented *)
+
+let pp_dependency = function
+ | IncludeDep str -> "include \"" ^ str ^ "\""
+ | BaseuriDep str -> "set \"baseuri\" \"" ^ str ^ "\""
+ | UriDep uri -> "uri \"" ^ UriManager.string_of_uri uri ^ "\""
+
--- /dev/null
+(* Copyright (C) 2004, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+val pp_tactic:
+ (CicNotationPt.term, CicNotationPt.term, GrafiteAst.reduction, string)
+ GrafiteAst.tactic ->
+ string
+
+val pp_command:
+ (CicNotationPt.term,CicNotationPt.obj) GrafiteAst.command -> string
+val pp_metadata: GrafiteAst.metadata -> string
+val pp_macro: ('a -> string) -> 'a GrafiteAst.macro -> string
+
+val pp_comment:
+ (CicNotationPt.term, CicNotationPt.term, GrafiteAst.reduction,
+ CicNotationPt.obj, string)
+ GrafiteAst.comment ->
+ string
+
+val pp_executable:
+ (CicNotationPt.term, CicNotationPt.term, GrafiteAst.reduction,
+ CicNotationPt.obj, string)
+ GrafiteAst.code ->
+ string
+
+val pp_statement:
+ (CicNotationPt.term, CicNotationPt.term, GrafiteAst.reduction,
+ CicNotationPt.obj, string)
+ GrafiteAst.statement ->
+ string
+
+val pp_macro_ast: CicNotationPt.term GrafiteAst.macro -> string
+val pp_macro_cic: Cic.term GrafiteAst.macro -> string
+
+val pp_tactical:
+ (CicNotationPt.term, CicNotationPt.term, GrafiteAst.reduction, string)
+ GrafiteAst.tactical ->
+ string
+
+val pp_alias: GrafiteAst.alias_spec -> string
+
+val pp_cic_command: (Cic.term,Cic.obj) GrafiteAst.command -> string
+
+val pp_dependency: GrafiteAst.dependency -> string
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Printf
+
+module Ast = CicNotationPt
+
+type statement =
+ (CicNotationPt.term, CicNotationPt.term, GrafiteAst.reduction,
+ CicNotationPt.obj, string)
+ GrafiteAst.statement
+
+let grammar = CicNotationParser.level2_ast_grammar
+
+let term = CicNotationParser.term
+let statement = Grammar.Entry.create grammar "statement"
+
+let add_raw_attribute ~text t = Ast.AttributedTerm (`Raw text, t)
+
+let default_precedence = 50
+let default_associativity = Gramext.NonA
+
+EXTEND
+ GLOBAL: term statement;
+ arg: [
+ [ LPAREN; names = LIST1 IDENT SEP SYMBOL ",";
+ SYMBOL ":"; ty = term; RPAREN -> names,ty
+ | name = IDENT -> [name],Ast.Implicit
+ ]
+ ];
+ constructor: [ [ name = IDENT; SYMBOL ":"; typ = term -> (name, typ) ] ];
+ tactic_term: [ [ t = term LEVEL "90N" -> t ] ];
+ ident_list0: [ [ LPAREN; idents = LIST0 IDENT; RPAREN -> idents ] ];
+ tactic_term_list1: [
+ [ tactic_terms = LIST1 tactic_term SEP SYMBOL "," -> tactic_terms ]
+ ];
+ reduction_kind: [
+ [ IDENT "normalize" -> `Normalize
+ | IDENT "reduce" -> `Reduce
+ | IDENT "simplify" -> `Simpl
+ | IDENT "unfold"; t = OPT term -> `Unfold t
+ | IDENT "whd" -> `Whd ]
+ ];
+ sequent_pattern_spec: [
+ [ hyp_paths =
+ LIST0
+ [ id = IDENT ;
+ path = OPT [SYMBOL ":" ; path = tactic_term -> path ] ->
+ (id,match path with Some p -> p | None -> Ast.UserInput) ];
+ goal_path = OPT [ SYMBOL <:unicode<vdash>>; term = tactic_term -> term ] ->
+ let goal_path =
+ match goal_path, hyp_paths with
+ None, [] -> Ast.UserInput
+ | None, _::_ -> Ast.Implicit
+ | Some goal_path, _ -> goal_path
+ in
+ hyp_paths,goal_path
+ ]
+ ];
+ pattern_spec: [
+ [ res = OPT [
+ "in";
+ wanted_and_sps =
+ [ "match" ; wanted = tactic_term ;
+ sps = OPT [ "in"; sps = sequent_pattern_spec -> sps ] ->
+ Some wanted,sps
+ | sps = sequent_pattern_spec ->
+ None,Some sps
+ ] ->
+ let wanted,hyp_paths,goal_path =
+ match wanted_and_sps with
+ wanted,None -> wanted, [], Ast.UserInput
+ | wanted,Some (hyp_paths,goal_path) -> wanted,hyp_paths,goal_path
+ in
+ wanted, hyp_paths, goal_path ] ->
+ match res with
+ None -> None,[],Ast.UserInput
+ | Some ps -> ps]
+ ];
+ direction: [
+ [ SYMBOL ">" -> `LeftToRight
+ | SYMBOL "<" -> `RightToLeft ]
+ ];
+ int: [ [ num = NUMBER -> int_of_string num ] ];
+ intros_spec: [
+ [ num = OPT [ num = int -> num ]; idents = OPT ident_list0 ->
+ let idents = match idents with None -> [] | Some idents -> idents in
+ num, idents
+ ]
+ ];
+ using: [ [ using = OPT [ IDENT "using"; t = tactic_term -> t ] -> using ] ];
+ tactic: [
+ [ IDENT "absurd"; t = tactic_term ->
+ GrafiteAst.Absurd (loc, t)
+ | IDENT "apply"; t = tactic_term ->
+ GrafiteAst.Apply (loc, t)
+ | IDENT "assumption" ->
+ GrafiteAst.Assumption loc
+ | IDENT "auto";
+ depth = OPT [ IDENT "depth"; SYMBOL "="; i = int -> i ];
+ width = OPT [ IDENT "width"; SYMBOL "="; i = int -> i ];
+ paramodulation = OPT [ IDENT "paramodulation" ];
+ full = OPT [ IDENT "full" ] -> (* ALB *)
+ GrafiteAst.Auto (loc,depth,width,paramodulation,full)
+ | IDENT "clear"; id = IDENT ->
+ GrafiteAst.Clear (loc,id)
+ | IDENT "clearbody"; id = IDENT ->
+ GrafiteAst.ClearBody (loc,id)
+ | IDENT "change"; what = pattern_spec; "with"; t = tactic_term ->
+ GrafiteAst.Change (loc, what, t)
+ | IDENT "compare"; t = tactic_term ->
+ GrafiteAst.Compare (loc,t)
+ | IDENT "constructor"; n = int ->
+ GrafiteAst.Constructor (loc, n)
+ | IDENT "contradiction" ->
+ GrafiteAst.Contradiction loc
+ | IDENT "cut"; t = tactic_term; ident = OPT [ "as"; id = IDENT -> id] ->
+ GrafiteAst.Cut (loc, ident, t)
+ | IDENT "decide"; IDENT "equality" ->
+ GrafiteAst.DecideEquality loc
+ | IDENT "decompose"; types = OPT ident_list0; what = IDENT;
+ (num, idents) = intros_spec ->
+ let types = match types with None -> [] | Some types -> types in
+ let to_spec id = GrafiteAst.Ident id in
+ GrafiteAst.Decompose (loc, List.rev_map to_spec types, what, idents)
+ | IDENT "discriminate"; t = tactic_term ->
+ GrafiteAst.Discriminate (loc, t)
+ | IDENT "elim"; what = tactic_term; using = using;
+ (num, idents) = intros_spec ->
+ GrafiteAst.Elim (loc, what, using, num, idents)
+ | IDENT "elimType"; what = tactic_term; using = using;
+ (num, idents) = intros_spec ->
+ GrafiteAst.ElimType (loc, what, using, num, idents)
+ | IDENT "exact"; t = tactic_term ->
+ GrafiteAst.Exact (loc, t)
+ | IDENT "exists" ->
+ GrafiteAst.Exists loc
+ | IDENT "fail" -> GrafiteAst.Fail loc
+ | IDENT "fold"; kind = reduction_kind; t = tactic_term; p = pattern_spec ->
+ let (pt,_,_) = p in
+ if pt <> None then
+ raise (HExtlib.Localized (loc, CicNotationParser.Parse_error
+ ("the pattern cannot specify the term to replace, only its"
+ ^ " paths in the hypotheses and in the conclusion")))
+ else
+ GrafiteAst.Fold (loc, kind, t, p)
+ | IDENT "fourier" ->
+ GrafiteAst.Fourier loc
+ | IDENT "fwd"; hyp = IDENT; idents = OPT ident_list0 ->
+ let idents = match idents with None -> [] | Some idents -> idents in
+ GrafiteAst.FwdSimpl (loc, hyp, idents)
+ | IDENT "generalize"; p=pattern_spec; id = OPT ["as" ; id = IDENT -> id] ->
+ GrafiteAst.Generalize (loc,p,id)
+ | IDENT "goal"; n = int ->
+ GrafiteAst.Goal (loc, n)
+ | IDENT "id" -> GrafiteAst.IdTac loc
+ | IDENT "injection"; t = tactic_term ->
+ GrafiteAst.Injection (loc, t)
+ | IDENT "intro"; ident = OPT IDENT ->
+ let idents = match ident with None -> [] | Some id -> [id] in
+ GrafiteAst.Intros (loc, Some 1, idents)
+ | IDENT "intros"; (num, idents) = intros_spec ->
+ GrafiteAst.Intros (loc, num, idents)
+ | IDENT "lapply";
+ depth = OPT [ IDENT "depth"; SYMBOL "="; i = int -> i ];
+ what = tactic_term;
+ to_what = OPT [ "to" ; t = tactic_term_list1 -> t ];
+ ident = OPT [ IDENT "using" ; ident = IDENT -> ident ] ->
+ let to_what = match to_what with None -> [] | Some to_what -> to_what in
+ GrafiteAst.LApply (loc, depth, to_what, what, ident)
+ | IDENT "left" -> GrafiteAst.Left loc
+ | IDENT "letin"; where = IDENT ; SYMBOL <:unicode<def>> ; t = tactic_term ->
+ GrafiteAst.LetIn (loc, t, where)
+ | kind = reduction_kind; p = pattern_spec ->
+ GrafiteAst.Reduce (loc, kind, p)
+ | IDENT "reflexivity" ->
+ GrafiteAst.Reflexivity loc
+ | IDENT "replace"; p = pattern_spec; "with"; t = tactic_term ->
+ GrafiteAst.Replace (loc, p, t)
+ | IDENT "rewrite" ; d = direction; t = tactic_term ; p = pattern_spec ->
+ let (pt,_,_) = p in
+ if pt <> None then
+ raise
+ (HExtlib.Localized (loc,
+ (CicNotationParser.Parse_error
+ "the pattern cannot specify the term to rewrite, only its paths in the hypotheses and in the conclusion")))
+ else
+ GrafiteAst.Rewrite (loc, d, t, p)
+ | IDENT "right" ->
+ GrafiteAst.Right loc
+ | IDENT "ring" ->
+ GrafiteAst.Ring loc
+ | IDENT "split" ->
+ GrafiteAst.Split loc
+ | IDENT "symmetry" ->
+ GrafiteAst.Symmetry loc
+ | IDENT "transitivity"; t = tactic_term ->
+ GrafiteAst.Transitivity (loc, t)
+ ]
+ ];
+ atomic_tactical:
+ [ "sequence" LEFTA
+ [ t1 = SELF; SYMBOL ";"; t2 = SELF ->
+ let ts =
+ match t1 with
+ | GrafiteAst.Seq (_, l) -> l @ [ t2 ]
+ | _ -> [ t1; t2 ]
+ in
+ GrafiteAst.Seq (loc, ts)
+ ]
+ | "then" NONA
+ [ tac = SELF; SYMBOL ";";
+ SYMBOL "["; tacs = LIST0 SELF SEP SYMBOL "|"; SYMBOL "]"->
+ (GrafiteAst.Then (loc, tac, tacs))
+ ]
+ | "loops" RIGHTA
+ [ IDENT "do"; count = int; tac = SELF; IDENT "end" ->
+ GrafiteAst.Do (loc, count, tac)
+ | IDENT "repeat"; tac = SELF; IDENT "end" -> GrafiteAst.Repeat (loc, tac)
+ ]
+ | "simple" NONA
+ [ IDENT "first";
+ SYMBOL "["; tacs = LIST0 SELF SEP SYMBOL "|"; SYMBOL "]"->
+ GrafiteAst.First (loc, tacs)
+ | IDENT "try"; tac = SELF -> GrafiteAst.Try (loc, tac)
+ | IDENT "solve";
+ SYMBOL "["; tacs = LIST0 SELF SEP SYMBOL "|"; SYMBOL "]"->
+ GrafiteAst.Solve (loc, tacs)
+ | LPAREN; tac = SELF; RPAREN -> tac
+ | tac = tactic -> GrafiteAst.Tactic (loc, tac)
+ ]
+ ];
+ punctuation_tactical:
+ [
+ [ SYMBOL "[" -> GrafiteAst.Branch loc
+ | SYMBOL "|" -> GrafiteAst.Shift loc
+ | i = int; SYMBOL ":" -> GrafiteAst.Pos (loc, i)
+ | SYMBOL "]" -> GrafiteAst.Merge loc
+ | SYMBOL ";" -> GrafiteAst.Semicolon loc
+ | SYMBOL "." -> GrafiteAst.Dot loc
+ ]
+ ];
+ tactical:
+ [ "simple" NONA
+ [ IDENT "focus"; goals = LIST1 int -> GrafiteAst.Focus (loc, goals)
+ | IDENT "unfocus" -> GrafiteAst.Unfocus loc
+ | IDENT "skip" -> GrafiteAst.Skip loc
+ | tac = atomic_tactical LEVEL "loops" -> tac
+ ]
+ ];
+ theorem_flavour: [
+ [ [ IDENT "definition" ] -> `Definition
+ | [ IDENT "fact" ] -> `Fact
+ | [ IDENT "lemma" ] -> `Lemma
+ | [ IDENT "remark" ] -> `Remark
+ | [ IDENT "theorem" ] -> `Theorem
+ ]
+ ];
+ inductive_spec: [ [
+ fst_name = IDENT; params = LIST0 [ arg=arg -> arg ];
+ SYMBOL ":"; fst_typ = term; SYMBOL <:unicode<def>>; OPT SYMBOL "|";
+ fst_constructors = LIST0 constructor SEP SYMBOL "|";
+ tl = OPT [ "with";
+ types = LIST1 [
+ name = IDENT; SYMBOL ":"; typ = term; SYMBOL <:unicode<def>>;
+ OPT SYMBOL "|"; constructors = LIST0 constructor SEP SYMBOL "|" ->
+ (name, true, typ, constructors) ] SEP "with" -> types
+ ] ->
+ let params =
+ List.fold_right
+ (fun (names, typ) acc ->
+ (List.map (fun name -> (name, typ)) names) @ acc)
+ params []
+ in
+ let fst_ind_type = (fst_name, true, fst_typ, fst_constructors) in
+ let tl_ind_types = match tl with None -> [] | Some types -> types in
+ let ind_types = fst_ind_type :: tl_ind_types in
+ (params, ind_types)
+ ] ];
+
+ record_spec: [ [
+ name = IDENT; params = LIST0 [ arg = arg -> arg ] ;
+ SYMBOL ":"; typ = term; SYMBOL <:unicode<def>>; SYMBOL "{" ;
+ fields = LIST0 [
+ name = IDENT ; SYMBOL ":" ; ty = term -> (name,ty)
+ ] SEP SYMBOL ";"; SYMBOL "}" ->
+ let params =
+ List.fold_right
+ (fun (names, typ) acc ->
+ (List.map (fun name -> (name, typ)) names) @ acc)
+ params []
+ in
+ (params,name,typ,fields)
+ ] ];
+
+ macro: [
+ [ [ IDENT "quit" ] -> GrafiteAst.Quit loc
+(* | [ IDENT "abort" ] -> GrafiteAst.Abort loc *)
+(* | [ IDENT "undo" ]; steps = OPT NUMBER ->
+ GrafiteAst.Undo (loc, int_opt steps)
+ | [ IDENT "redo" ]; steps = OPT NUMBER ->
+ GrafiteAst.Redo (loc, int_opt steps) *)
+ | [ IDENT "check" ]; t = term ->
+ GrafiteAst.Check (loc, t)
+ | [ IDENT "hint" ] -> GrafiteAst.Hint loc
+ | [ IDENT "whelp"; "match" ] ; t = term ->
+ GrafiteAst.WMatch (loc,t)
+ | [ IDENT "whelp"; IDENT "instance" ] ; t = term ->
+ GrafiteAst.WInstance (loc,t)
+ | [ IDENT "whelp"; IDENT "locate" ] ; id = IDENT ->
+ GrafiteAst.WLocate (loc,id)
+ | [ IDENT "whelp"; IDENT "elim" ] ; t = term ->
+ GrafiteAst.WElim (loc, t)
+ | [ IDENT "whelp"; IDENT "hint" ] ; t = term ->
+ GrafiteAst.WHint (loc,t)
+ | [ IDENT "print" ]; name = QSTRING -> GrafiteAst.Print (loc, name)
+ ]
+ ];
+ alias_spec: [
+ [ IDENT "id"; id = QSTRING; SYMBOL "="; uri = QSTRING ->
+ let alpha = "[a-zA-Z]" in
+ let num = "[0-9]+" in
+ let ident_cont = "\\("^alpha^"\\|"^num^"\\|_\\|\\\\\\)" in
+ let ident = "\\("^alpha^ident_cont^"*\\|_"^ident_cont^"+\\)" in
+ let rex = Str.regexp ("^"^ident^"$") in
+ if Str.string_match rex id 0 then
+ if (try ignore (UriManager.uri_of_string uri); true
+ with UriManager.IllFormedUri _ -> false)
+ then
+ GrafiteAst.Ident_alias (id, uri)
+ else
+ raise
+ (HExtlib.Localized (loc, CicNotationParser.Parse_error (sprintf "Not a valid uri: %s" uri)))
+ else
+ raise (HExtlib.Localized (loc, CicNotationParser.Parse_error (
+ sprintf "Not a valid identifier: %s" id)))
+ | IDENT "symbol"; symbol = QSTRING;
+ instance = OPT [ LPAREN; IDENT "instance"; n = int; RPAREN -> n ];
+ SYMBOL "="; dsc = QSTRING ->
+ let instance =
+ match instance with Some i -> i | None -> 0
+ in
+ GrafiteAst.Symbol_alias (symbol, instance, dsc)
+ | IDENT "num";
+ instance = OPT [ LPAREN; IDENT "instance"; n = int; RPAREN -> n ];
+ SYMBOL "="; dsc = QSTRING ->
+ let instance =
+ match instance with Some i -> i | None -> 0
+ in
+ GrafiteAst.Number_alias (instance, dsc)
+ ]
+ ];
+ argument: [
+ [ l = LIST0 [ SYMBOL <:unicode<eta>> (* η *); SYMBOL "." -> () ];
+ id = IDENT ->
+ Ast.IdentArg (List.length l, id)
+ ]
+ ];
+ associativity: [
+ [ IDENT "left"; IDENT "associative" -> Gramext.LeftA
+ | IDENT "right"; IDENT "associative" -> Gramext.RightA
+ | IDENT "non"; IDENT "associative" -> Gramext.NonA
+ ]
+ ];
+ precedence: [
+ [ "with"; IDENT "precedence"; n = NUMBER -> int_of_string n ]
+ ];
+ notation: [
+ [ dir = OPT direction; s = QSTRING;
+ assoc = OPT associativity; prec = OPT precedence;
+ IDENT "for";
+ p2 =
+ [ blob = UNPARSED_AST ->
+ add_raw_attribute ~text:(sprintf "@{%s}" blob)
+ (CicNotationParser.parse_level2_ast
+ (Ulexing.from_utf8_string blob))
+ | blob = UNPARSED_META ->
+ add_raw_attribute ~text:(sprintf "${%s}" blob)
+ (CicNotationParser.parse_level2_meta
+ (Ulexing.from_utf8_string blob))
+ ] ->
+ let assoc =
+ match assoc with
+ | None -> default_associativity
+ | Some assoc -> assoc
+ in
+ let prec =
+ match prec with
+ | None -> default_precedence
+ | Some prec -> prec
+ in
+ let p1 =
+ add_raw_attribute ~text:s
+ (CicNotationParser.parse_level1_pattern
+ (Ulexing.from_utf8_string s))
+ in
+ (dir, p1, assoc, prec, p2)
+ ]
+ ];
+ level3_term: [
+ [ u = URI -> Ast.UriPattern (UriManager.uri_of_string u)
+ | id = IDENT -> Ast.VarPattern id
+ | SYMBOL "_" -> Ast.ImplicitPattern
+ | LPAREN; terms = LIST1 SELF; RPAREN ->
+ (match terms with
+ | [] -> assert false
+ | [term] -> term
+ | terms -> Ast.ApplPattern terms)
+ ]
+ ];
+ interpretation: [
+ [ s = CSYMBOL; args = LIST0 argument; SYMBOL "="; t = level3_term ->
+ (s, args, t)
+ ]
+ ];
+ command: [ [
+ IDENT "set"; n = QSTRING; v = QSTRING ->
+ GrafiteAst.Set (loc, n, v)
+ | IDENT "drop" -> GrafiteAst.Drop loc
+ | IDENT "qed" -> GrafiteAst.Qed loc
+ | IDENT "variant" ; name = IDENT; SYMBOL ":";
+ typ = term; SYMBOL <:unicode<def>> ; newname = IDENT ->
+ GrafiteAst.Obj (loc,
+ Ast.Theorem
+ (`Variant,name,typ,Some (Ast.Ident (newname, None))))
+ | flavour = theorem_flavour; name = IDENT; SYMBOL ":"; typ = term;
+ body = OPT [ SYMBOL <:unicode<def>> (* ≝ *); body = term -> body ] ->
+ GrafiteAst.Obj (loc, Ast.Theorem (flavour, name, typ, body))
+ | flavour = theorem_flavour; name = IDENT; SYMBOL <:unicode<def>> (* ≝ *);
+ body = term ->
+ GrafiteAst.Obj (loc,
+ Ast.Theorem (flavour, name, Ast.Implicit, Some body))
+ | "let"; ind_kind = [ "corec" -> `CoInductive | "rec"-> `Inductive ];
+ defs = CicNotationParser.let_defs ->
+ let name,ty =
+ match defs with
+ | ((Ast.Ident (name, None), Some ty),_,_) :: _ -> name,ty
+ | ((Ast.Ident (name, None), None),_,_) :: _ ->
+ name, Ast.Implicit
+ | _ -> assert false
+ in
+ let body = Ast.Ident (name,None) in
+ GrafiteAst.Obj (loc, Ast.Theorem(`Definition, name, ty,
+ Some (Ast.LetRec (ind_kind, defs, body))))
+ | IDENT "inductive"; spec = inductive_spec ->
+ let (params, ind_types) = spec in
+ GrafiteAst.Obj (loc, Ast.Inductive (params, ind_types))
+ | IDENT "coinductive"; spec = inductive_spec ->
+ let (params, ind_types) = spec in
+ let ind_types = (* set inductive flags to false (coinductive) *)
+ List.map (fun (name, _, term, ctors) -> (name, false, term, ctors))
+ ind_types
+ in
+ GrafiteAst.Obj (loc, Ast.Inductive (params, ind_types))
+ | IDENT "coercion" ; name = IDENT ->
+ GrafiteAst.Coercion (loc, Ast.Ident (name,Some []))
+ | IDENT "coercion" ; name = URI ->
+ GrafiteAst.Coercion (loc, Ast.Uri (name,Some []))
+ | IDENT "alias" ; spec = alias_spec ->
+ GrafiteAst.Alias (loc, spec)
+ | IDENT "record" ; (params,name,ty,fields) = record_spec ->
+ GrafiteAst.Obj (loc, Ast.Record (params,name,ty,fields))
+ | IDENT "include" ; path = QSTRING ->
+ GrafiteAst.Include (loc,path)
+ | IDENT "default" ; what = QSTRING ; uris = LIST1 URI ->
+ let uris = List.map UriManager.uri_of_string uris in
+ GrafiteAst.Default (loc,what,uris)
+ | IDENT "notation"; (dir, l1, assoc, prec, l2) = notation ->
+ GrafiteAst.Notation (loc, dir, l1, assoc, prec, l2)
+ | IDENT "interpretation"; id = QSTRING;
+ (symbol, args, l3) = interpretation ->
+ GrafiteAst.Interpretation (loc, id, (symbol, args), l3)
+ | IDENT "metadata"; [ IDENT "dependency" | IDENT "baseuri" ] ; URI ->
+ (** metadata commands lives only in .moo, where they are in marshalled
+ * form *)
+ raise (HExtlib.Localized (loc,CicNotationParser.Parse_error "metadata not allowed here"))
+
+ | IDENT "dump" -> GrafiteAst.Dump loc
+ | IDENT "render"; u = URI ->
+ GrafiteAst.Render (loc, UriManager.uri_of_string u)
+ ]];
+ executable: [
+ [ cmd = command; SYMBOL "." -> GrafiteAst.Command (loc, cmd)
+ | tac = tactical; punct = punctuation_tactical ->
+ GrafiteAst.Tactical (loc, tac, Some punct)
+ | punct = punctuation_tactical -> GrafiteAst.Tactical (loc, punct, None)
+ | mac = macro; SYMBOL "." -> GrafiteAst.Macro (loc, mac)
+ ]
+ ];
+ comment: [
+ [ BEGINCOMMENT ; ex = executable ; ENDCOMMENT ->
+ GrafiteAst.Code (loc, ex)
+ | str = NOTE ->
+ GrafiteAst.Note (loc, str)
+ ]
+ ];
+ statement: [
+ [ ex = executable -> GrafiteAst.Executable (loc,ex)
+ | com = comment -> GrafiteAst.Comment (loc, com)
+ | EOI -> raise End_of_file
+ ]
+ ];
+END
+
+let exc_located_wrapper f =
+ try
+ f ()
+ with
+ | Stdpp.Exc_located (_, End_of_file) -> raise End_of_file
+ | Stdpp.Exc_located (floc, Stream.Error msg) ->
+ raise (HExtlib.Localized (floc,CicNotationParser.Parse_error msg))
+ | Stdpp.Exc_located (floc, exn) ->
+ raise
+ (HExtlib.Localized (floc,CicNotationParser.Parse_error (Printexc.to_string exn)))
+
+let parse_statement lexbuf =
+ exc_located_wrapper
+ (fun () -> (Grammar.Entry.parse statement (Obj.magic lexbuf)))
+
+let parse_dependencies lexbuf =
+ let tok_stream,_ =
+ CicNotationLexer.level2_ast_lexer.Token.tok_func (Obj.magic lexbuf)
+ in
+ let rec parse acc =
+ (parser
+ | [< '("URI", u) >] ->
+ parse (GrafiteAst.UriDep (UriManager.uri_of_string u) :: acc)
+ | [< '("IDENT", "include"); '("QSTRING", fname) >] ->
+ parse (GrafiteAst.IncludeDep fname :: acc)
+ | [< '("IDENT", "set"); '("QSTRING", "baseuri"); '("QSTRING", baseuri) >] ->
+ parse (GrafiteAst.BaseuriDep baseuri :: acc)
+ | [< '("EOI", _) >] -> acc
+ | [< 'tok >] -> parse acc
+ | [< >] -> acc) tok_stream
+ in
+ List.rev (parse [])
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+type statement =
+ (CicNotationPt.term, CicNotationPt.term, GrafiteAst.reduction,
+ CicNotationPt.obj, string)
+ GrafiteAst.statement
+
+val parse_statement: Ulexing.lexbuf -> statement (** @raise End_of_file *)
+
+ (** @raise End_of_file *)
+val parse_dependencies: Ulexing.lexbuf -> GrafiteAst.dependency list
+
+val statement: statement Grammar.Entry.e
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Gramext
+
+let tex_of_unicode s =
+ let contractions = ("\\Longrightarrow","=>") :: [] in
+ if String.length s <= 1 then s
+ else (* probably an extended unicode symbol *)
+ let s = Utf8Macro.tex_of_unicode s in
+ try List.assoc s contractions with Not_found -> s
+
+let needs_brackets t =
+ let rec count_brothers = function
+ | Node {brother = brother} -> 1 + count_brothers brother
+ | _ -> 0
+ in
+ count_brothers t > 1
+
+let visit_description desc fmt self =
+ let skip s = List.mem s [ ] in
+ let inline s = List.mem s [ "int" ] in
+
+ let rec visit_entry e todo is_son nesting =
+ let { ename = ename; edesc = desc } = e in
+ if inline ename then
+ visit_desc desc todo is_son nesting
+ else
+ begin
+ Format.fprintf fmt "%s " ename;
+ if skip ename then
+ todo
+ else
+ todo @ [e]
+ end
+
+ and visit_desc d todo is_son nesting =
+ match d with
+ | Dlevels [] -> todo
+ | Dlevels [lev] -> visit_level lev todo is_son nesting
+ | Dlevels (lev::levels) ->
+ let todo = visit_level lev todo is_son nesting in
+ List.fold_left
+ (fun acc l ->
+ Format.fprintf fmt "@ | ";
+ visit_level l acc is_son nesting)
+ todo levels;
+ | _ -> todo
+
+ and visit_level l todo is_son nesting =
+ let { lsuffix = suff ; lprefix = pref } = l in
+ let todo = visit_tree suff todo is_son nesting in
+ visit_tree pref todo is_son nesting
+
+ and visit_tree t todo is_son nesting =
+ match t with
+ | Node node -> visit_node node todo is_son nesting
+ | _ -> todo
+
+ and visit_node n todo is_son nesting =
+ let is_tree_printable t =
+ match t with
+ | Node _ -> true
+ | _ -> false
+ in
+ let { node = symbol; son = son ; brother = brother } = n in
+ let todo = visit_symbol symbol todo is_son nesting in
+ let todo =
+ if is_tree_printable son then
+ begin
+ let need_b = needs_brackets son in
+ if not is_son then
+ Format.fprintf fmt "@[<hov2>";
+ if need_b then
+ Format.fprintf fmt "( ";
+ let todo = visit_tree son todo true nesting in
+ if need_b then
+ Format.fprintf fmt ")";
+ if not is_son then
+ Format.fprintf fmt "@]";
+ todo
+ end
+ else
+ todo
+ in
+ if is_tree_printable brother then
+ begin
+ Format.fprintf fmt "@ | ";
+ visit_tree brother todo is_son nesting
+ end
+ else
+ todo
+
+ and visit_symbol s todo is_son nesting =
+ match s with
+ | Smeta (name, sl, _) ->
+ Format.fprintf fmt "%s " name;
+ List.fold_left (
+ fun acc s ->
+ let todo = visit_symbol s acc is_son nesting in
+ if is_son then
+ Format.fprintf fmt "@ ";
+ todo)
+ todo sl
+ | Snterm entry -> visit_entry entry todo is_son nesting
+ | Snterml (entry,_) -> visit_entry entry todo is_son nesting
+ | Slist0 symbol ->
+ Format.fprintf fmt "{@[<hov2> ";
+ let todo = visit_symbol symbol todo is_son (nesting+1) in
+ Format.fprintf fmt "@]} @ ";
+ todo
+ | Slist0sep (symbol,sep) ->
+ Format.fprintf fmt "[@[<hov2> ";
+ let todo = visit_symbol symbol todo is_son (nesting + 1) in
+ Format.fprintf fmt "{@[<hov2> ";
+ let todo = visit_symbol sep todo is_son (nesting + 2) in
+ Format.fprintf fmt " ";
+ let todo = visit_symbol symbol todo is_son (nesting + 2) in
+ Format.fprintf fmt "@]} @]] @ ";
+ todo
+ | Slist1 symbol ->
+ Format.fprintf fmt "{@[<hov2> ";
+ let todo = visit_symbol symbol todo is_son (nesting + 1) in
+ Format.fprintf fmt "@]}+ @ ";
+ todo
+ | Slist1sep (symbol,sep) ->
+ let todo = visit_symbol symbol todo is_son nesting in
+ Format.fprintf fmt "{@[<hov2> ";
+ let todo = visit_symbol sep todo is_son (nesting + 1) in
+ let todo = visit_symbol symbol todo is_son (nesting + 1) in
+ Format.fprintf fmt "@]} @ ";
+ todo
+ | Sopt symbol ->
+ Format.fprintf fmt "[@[<hov2> ";
+ let todo = visit_symbol symbol todo is_son (nesting + 1) in
+ Format.fprintf fmt "@]] @ ";
+ todo
+ | Sself -> Format.fprintf fmt "%s " self; todo
+ | Snext -> Format.fprintf fmt "next "; todo
+ | Stoken pattern ->
+ let constructor, keyword = pattern in
+ if keyword = "" then
+ Format.fprintf fmt "`%s' " constructor
+ else
+ Format.fprintf fmt "\"%s\" " (tex_of_unicode keyword);
+ todo
+ | Stree tree ->
+ if needs_brackets tree then
+ begin
+ Format.fprintf fmt "@[<hov2>( ";
+ let todo = visit_tree tree todo is_son (nesting + 1) in
+ Format.fprintf fmt ")@] @ ";
+ todo
+ end
+ else
+ visit_tree tree todo is_son (nesting + 1)
+ in
+ visit_desc desc [] false 0
+;;
+
+let rec clean_dummy_desc = function
+ | Dlevels l -> Dlevels (clean_levels l)
+ | x -> x
+
+and clean_levels = function
+ | [] -> []
+ | l :: tl -> clean_level l @ clean_levels tl
+
+and clean_level = function
+ | x ->
+ let pref = clean_tree x.lprefix in
+ let suff = clean_tree x.lsuffix in
+ match pref,suff with
+ | DeadEnd, DeadEnd -> []
+ | _ -> [{x with lprefix = pref; lsuffix = suff}]
+
+and clean_tree = function
+ | Node n -> clean_node n
+ | x -> x
+
+and clean_node = function
+ | {node=node;son=son;brother=brother} ->
+ let bn = is_symbol_dummy node in
+ let bs = is_tree_dummy son in
+ let bb = is_tree_dummy brother in
+ let son = if bs then DeadEnd else son in
+ let brother = if bb then DeadEnd else brother in
+ if bb && bs && bn then
+ DeadEnd
+ else
+ if bn then
+ Node {node=Sself;son=son;brother=brother}
+ else
+ Node {node=node;son=son;brother=brother}
+
+and is_level_dummy = function
+ | {lsuffix=lsuffix;lprefix=lprefix} ->
+ is_tree_dummy lsuffix && is_tree_dummy lprefix
+
+and is_desc_dummy = function
+ | Dlevels l -> List.for_all is_level_dummy l
+ | Dparser _ -> true
+
+and is_entry_dummy = function
+ | {edesc=edesc} -> is_desc_dummy edesc
+
+and is_symbol_dummy = function
+ | Stoken ("DUMMY", _) -> true
+ | Stoken _ -> false
+ | Smeta (_, lt, _) -> List.for_all is_symbol_dummy lt
+ | Snterm e | Snterml (e, _) -> is_entry_dummy e
+ | Slist1 x | Slist0 x -> is_symbol_dummy x
+ | Slist1sep (x,y) | Slist0sep (x,y) -> is_symbol_dummy x && is_symbol_dummy y
+ | Sopt x -> is_symbol_dummy x
+ | Sself | Snext -> false
+ | Stree t -> is_tree_dummy t
+
+and is_tree_dummy = function
+ | Node {node=node} -> is_symbol_dummy node
+ | _ -> true
+;;
+
+
+let rec visit_entries todo pped =
+ let fmt = Format.std_formatter in
+ match todo with
+ | [] -> ()
+ | hd :: tl ->
+ let todo =
+ if not (List.memq hd pped) then
+ begin
+ let { ename = ename; edesc = desc } = hd in
+ Format.fprintf fmt "@[<hv2>%s ::=@ " ename;
+ let desc = clean_dummy_desc desc in
+ let todo = visit_description desc fmt ename @ todo in
+ Format.fprintf fmt "@]";
+ Format.pp_print_newline fmt ();
+ Format.pp_print_newline fmt ();
+ todo
+ end
+ else
+ todo
+ in
+ let clean_todo todo =
+ let name_of_entry e = e.ename in
+ let pped = hd :: pped in
+ let todo = tl @ todo in
+ let todo = List.filter (fun e -> not(List.memq e pped)) todo in
+ HExtlib.list_uniq
+ ~eq:(fun e1 e2 -> (name_of_entry e1) = (name_of_entry e2))
+ (List.sort
+ (fun e1 e2 ->
+ Pervasives.compare (name_of_entry e1) (name_of_entry e2))
+ todo),
+ pped
+ in
+ let todo,pped = clean_todo todo in
+ visit_entries todo pped
+;;
+
+let _ =
+ let g_entry = Grammar.Entry.obj GrafiteParser.statement in
+ visit_entries [g_entry] []
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+let _ =
+ let ic = ref stdin in
+ let usage = "test_coarse_parser [ file ]" in
+ let open_file fname =
+ if !ic <> stdin then close_in !ic;
+ ic := open_in fname
+ in
+ Arg.parse [] open_file usage;
+ let deps =
+ GrafiteParser.parse_dependencies (Ulexing.from_utf8_channel !ic)
+ in
+ List.iter (fun dep -> print_endline (GrafiteAstPp.pp_dependency dep)) deps
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Printf
+
+let _ = Helm_registry.load_from "test_parser.conf.xml"
+
+let xml_stream_of_markup =
+ let rec print_box (t: CicNotationPres.boxml_markup) =
+ Box.box2xml print_mpres t
+ and print_mpres (t: CicNotationPres.mathml_markup) =
+ Mpresentation.print_mpres print_box t
+ in
+ print_mpres
+
+let dump_xml t id_to_uri fname =
+ prerr_endline (sprintf "dumping MathML to %s ..." fname);
+ flush stdout;
+ let oc = open_out fname in
+ let markup = CicNotationPres.render id_to_uri t in
+ let xml_stream = CicNotationPres.print_xml markup in
+ Xml.pp_to_outchan xml_stream oc;
+ close_out oc
+
+let extract_loc =
+ function
+ | GrafiteAst.Executable (loc, _)
+ | GrafiteAst.Comment (loc, _) -> loc
+
+let pp_associativity = function
+ | Gramext.LeftA -> "left"
+ | Gramext.RightA -> "right"
+ | Gramext.NonA -> "non"
+
+let pp_precedence = string_of_int
+
+(* let last_rule_id = ref None *)
+
+let process_stream istream =
+ let char_count = ref 0 in
+ let module P = CicNotationPt in
+ let module G = GrafiteAst in
+ try
+ while true do
+ try
+ let statement = GrafiteParser.parse_statement istream in
+ let floc = extract_loc statement in
+ let (_, y) = HExtlib.loc_of_floc floc in
+ char_count := y + !char_count;
+ match statement with
+(* | G.Executable (_, G.Macro (_, G.Check (_,
+ P.AttributedTerm (_, P.Ident _)))) ->
+ prerr_endline "mega hack";
+ (match !last_rule_id with
+ | None -> ()
+ | Some id ->
+ prerr_endline "removing last notation rule ...";
+ CicNotationParser.delete id) *)
+ | G.Executable (_, G.Macro (_, G.Check (_, t))) ->
+ prerr_endline (sprintf "ast: %s" (CicNotationPp.pp_term t));
+ let t' = TermContentPres.pp_ast t in
+ prerr_endline (sprintf "rendered ast: %s"
+ (CicNotationPp.pp_term t'));
+ let tbl = Hashtbl.create 0 in
+ dump_xml t' tbl "out.xml"
+ | G.Executable (_, G.Command (_,
+ G.Notation (_, dir, l1, associativity, precedence, l2))) ->
+ prerr_endline "notation";
+ prerr_endline (sprintf "l1: %s" (CicNotationPp.pp_term l1));
+ prerr_endline (sprintf "l2: %s" (CicNotationPp.pp_term l2));
+ prerr_endline (sprintf "prec: %s" (pp_precedence precedence));
+ prerr_endline (sprintf "assoc: %s" (pp_associativity associativity));
+ let keywords = CicNotationUtil.keywords_of_term l1 in
+ if keywords <> [] then
+ prerr_endline (sprintf "keywords: %s"
+ (String.concat " " keywords));
+ if dir <> Some `RightToLeft then
+ ignore
+ (CicNotationParser.extend l1 ?precedence ?associativity
+ (fun env loc -> TermContentPres.instantiate_level2 env l2));
+(* last_rule_id := Some rule_id; *)
+ if dir <> Some `LeftToRight then
+ ignore (TermContentPres.add_pretty_printer
+ ?precedence ?associativity l2 l1)
+ | G.Executable (_, G.Command (_, G.Interpretation (_, id, l2, l3))) ->
+ prerr_endline "interpretation";
+ prerr_endline (sprintf "dsc: %s" id);
+ ignore (TermAcicContent.add_interpretation id l2 l3);
+ flush stdout
+ | G.Executable (_, G.Command (_, G.Dump _)) ->
+ CicNotationParser.print_l2_pattern (); print_newline ()
+ | G.Executable (_, G.Command (_, G.Render (_, uri))) ->
+ let obj, _ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ let annobj, _, _, id_to_sort, _, _, _ =
+ Cic2acic.acic_object_of_cic_object obj
+ in
+ let annterm =
+ match annobj with
+ | Cic.AConstant (_, _, _, _, ty, _, _)
+ | Cic.AVariable (_, _, _, ty, _, _) -> ty
+ | _ -> assert false
+ in
+ let t, id_to_uri =
+ TermAcicContent.ast_of_acic id_to_sort annterm
+ in
+ prerr_endline "Raw AST";
+ prerr_endline (CicNotationPp.pp_term t);
+ let t' = TermContentPres.pp_ast t in
+ prerr_endline "Rendered AST";
+ prerr_endline (CicNotationPp.pp_term t');
+ dump_xml t' id_to_uri "out.xml"
+ | _ -> prerr_endline "Unsupported statement"
+ with
+ | End_of_file -> raise End_of_file
+ | HExtlib.Localized (floc,CicNotationParser.Parse_error msg) ->
+ let (x, y) = HExtlib.loc_of_floc floc in
+(* let before = String.sub line 0 x in
+ let error = String.sub line x (y - x) in
+ let after = String.sub line y (String.length line - y) in
+ eprintf "%s\e[01;31m%s\e[00m%s\n" before error after;
+ prerr_endline (sprintf "at character %d-%d: %s" x y msg) *)
+ prerr_endline (sprintf "Parse error at character %d-%d: %s"
+ (!char_count + x) (!char_count + y) msg)
+ | exn ->
+ prerr_endline
+ (sprintf "Uncaught exception: %s" (Printexc.to_string exn))
+ done
+ with End_of_file -> ()
+
+let _ =
+ let arg_spec = [ ] in
+ let usage = "" in
+ Arg.parse arg_spec (fun _ -> raise (Arg.Bad usage)) usage;
+ print_endline "Loading builtin notation ...";
+ CicNotation.load_notation (Helm_registry.get "notation.core_file");
+ print_endline "done.";
+ flush stdout;
+ process_stream (Ulexing.from_utf8_channel stdin)
+
--- /dev/null
+*.cm[iaox]
+*.cmxa
--- /dev/null
+domMisc.cmo: domMisc.cmi
+domMisc.cmx: domMisc.cmi
+xml2Gdome.cmo: xml2Gdome.cmi
+xml2Gdome.cmx: xml2Gdome.cmi
--- /dev/null
+PACKAGE = hgdome
+
+# modules which have both a .ml and a .mli
+INTERFACE_FILES = \
+ domMisc.mli \
+ xml2Gdome.mli \
+ $(NULL)
+
+IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
+
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 06/01/2002 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+let domImpl = Gdome.domImplementation ()
+let helm_ns = Gdome.domString "http://www.cs.unibo.it/helm"
+let xlink_ns = Gdome.domString "http://www.w3.org/1999/xlink"
+let mathml_ns = Gdome.domString "http://www.w3.org/1998/Math/MathML"
+let boxml_ns = Gdome.domString "http://helm.cs.unibo.it/2003/BoxML"
+
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 15/01/2003 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+val domImpl : Gdome.domImplementation
+
+val helm_ns : Gdome.domString (** HELM namespace *)
+val xlink_ns : Gdome.domString (** XLink namespace *)
+val mathml_ns : Gdome.domString (** MathML namespace *)
+val boxml_ns : Gdome.domString (** BoxML namespace *)
+
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+let document_of_xml (domImplementation : Gdome.domImplementation) strm =
+ let module G = Gdome in
+ let module X = Xml in
+ let rec update_namespaces ((defaultns,bindings) as namespaces) =
+ function
+ [] -> namespaces
+ | (None,"xmlns",value)::tl ->
+ update_namespaces (Some (Gdome.domString value),bindings) tl
+ | (prefix,name,value)::tl when prefix = Some "xmlns" ->
+ update_namespaces (defaultns,(name,Gdome.domString value)::bindings) tl
+ | _::tl -> update_namespaces namespaces tl in
+ let rec namespace_of_prefix (defaultns,bindings) =
+ function
+ None -> None
+ | Some "xmlns" -> Some (Gdome.domString "xml-ns")
+ | Some p' ->
+ try
+ Some (List.assoc p' bindings)
+ with
+ Not_found ->
+ raise
+ (Failure ("The prefix " ^ p' ^ " is not bound to any namespace")) in
+ let get_qualified_name p n =
+ match p with
+ None -> Gdome.domString n
+ | Some p' -> Gdome.domString (p' ^ ":" ^ n) in
+ let root_prefix,root_name,root_attributes,root_content =
+ ignore (Stream.next strm) ; (* to skip the <?xml ...?> declaration *)
+ ignore (Stream.next strm) ; (* to skip the DOCTYPE declaration *)
+ match Stream.next strm with
+ X.Empty(p,n,l) -> p,n,l,[<>]
+ | X.NEmpty(p,n,l,c) -> p,n,l,c
+ | _ -> assert false
+ in
+ let namespaces = update_namespaces (None,[]) root_attributes in
+ let namespaceURI = namespace_of_prefix namespaces root_prefix in
+ let document =
+ domImplementation#createDocument ~namespaceURI
+ ~qualifiedName:(get_qualified_name root_prefix root_name)
+ ~doctype:None
+ in
+ let rec aux namespaces (node : Gdome.node) =
+ parser
+ [< 'X.Str a ; s >] ->
+ let textnode = document#createTextNode ~data:(Gdome.domString a) in
+ ignore (node#appendChild ~newChild:(textnode :> Gdome.node)) ;
+ aux namespaces node s
+ | [< 'X.Empty(p,n,l) ; s >] ->
+ let namespaces' = update_namespaces namespaces l in
+ let namespaceURI = namespace_of_prefix namespaces' p in
+ let element =
+ document#createElementNS ~namespaceURI
+ ~qualifiedName:(get_qualified_name p n)
+ in
+ List.iter
+ (function (p,n,v) ->
+ if p = None then
+ element#setAttribute ~name:(Gdome.domString n)
+ ~value:(Gdome.domString v)
+ else
+ let namespaceURI = namespace_of_prefix namespaces' p in
+ element#setAttributeNS
+ ~namespaceURI
+ ~qualifiedName:(get_qualified_name p n)
+ ~value:(Gdome.domString v)
+ ) l ;
+ ignore
+ (node#appendChild
+ ~newChild:(element : Gdome.element :> Gdome.node)) ;
+ aux namespaces node s
+ | [< 'X.NEmpty(p,n,l,c) ; s >] ->
+ let namespaces' = update_namespaces namespaces l in
+ let namespaceURI = namespace_of_prefix namespaces' p in
+ let element =
+ document#createElementNS ~namespaceURI
+ ~qualifiedName:(get_qualified_name p n)
+ in
+ List.iter
+ (function (p,n,v) ->
+ if p = None then
+ element#setAttribute ~name:(Gdome.domString n)
+ ~value:(Gdome.domString v)
+ else
+ let namespaceURI = namespace_of_prefix namespaces' p in
+ element#setAttributeNS ~namespaceURI
+ ~qualifiedName:(get_qualified_name p n)
+ ~value:(Gdome.domString v)
+ ) l ;
+ ignore (node#appendChild ~newChild:(element :> Gdome.node)) ;
+ aux namespaces' (element :> Gdome.node) c ;
+ aux namespaces node s
+ | [< >] -> ()
+ in
+ let root = document#get_documentElement in
+ List.iter
+ (function (p,n,v) ->
+ if p = None then
+ root#setAttribute ~name:(Gdome.domString n)
+ ~value:(Gdome.domString v)
+ else
+ let namespaceURI = namespace_of_prefix namespaces p in
+ root#setAttributeNS ~namespaceURI
+ ~qualifiedName:(get_qualified_name p n)
+ ~value:(Gdome.domString v)
+ ) root_attributes ;
+ aux namespaces (root : Gdome.element :> Gdome.node) root_content ;
+ document
+;;
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val document_of_xml :
+ Gdome.domImplementation -> Xml.token Stream.t -> Gdome.document
] stream
>]
+ (* TODO BRRRRR .... *)
+ (** strip first 4 line of a string, used to strip xml declaration and doctype
+ declaration from XML strings generated by Xml.pp_to_string *)
+let strip_xml_headings s =
+ let rec aux n pos =
+ if n = 0
+ then String.sub s pos (String.length s - pos)
+ else aux (n - 1) (String.index_from s pos '\n' + 1)
+ in
+ try
+ aux 4 0
+ with Not_found -> s
+
val add_xml_declaration: token Stream.t -> token Stream.t
+val strip_xml_headings: string -> string
+
projects / helm.git / commitdiff