From: Stefano Zacchiroli Date: Thu, 24 Nov 2005 18:25:43 +0000 (+0000) Subject: Reshaped structure of ocaml/ libraries. X-Git-Tag: make_still_working~8115 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=9a0e4f3be9f70662f18d2d3b6dd60ae79fba565b;p=helm.git Reshaped structure of ocaml/ libraries. Verbose list of the changes: Modified Files: Makefile.in METAS/meta.helm-cic_disambiguation.src cic_disambiguation/.depend cic_disambiguation/Makefile cic_disambiguation/disambiguate.ml cic_disambiguation/disambiguate.mli cic_disambiguation/disambiguateChoices.ml cic_disambiguation/disambiguateTypes.ml cic_disambiguation/disambiguateTypes.mli extlib/.depend extlib/Makefile xml/xml.ml xml/xml.mli Added Files: METAS/meta.helm-acic_content.src METAS/meta.helm-cic_acic.src METAS/meta.helm-content_pres.src METAS/meta.helm-grafite.src METAS/meta.helm-hgdome.src acic_content/.cvsignore acic_content/.depend acic_content/Makefile acic_content/acic2astMatcher.ml acic_content/acic2astMatcher.mli acic_content/acic2content.ml acic_content/acic2content.mli acic_content/cicNotationEnv.ml acic_content/cicNotationEnv.mli acic_content/cicNotationPp.ml acic_content/cicNotationPp.mli acic_content/cicNotationPt.ml acic_content/cicNotationUtil.ml acic_content/cicNotationUtil.mli acic_content/content.ml acic_content/content.mli acic_content/content2cic.ml acic_content/content2cic.mli acic_content/contentPp.ml acic_content/contentPp.mli acic_content/termAcicContent.ml acic_content/termAcicContent.mli cic_acic/.cvsignore cic_acic/.depend cic_acic/Makefile cic_acic/cic2Xml.ml cic_acic/cic2Xml.mli cic_acic/cic2acic.ml cic_acic/cic2acic.mli cic_acic/doubleTypeInference.ml cic_acic/doubleTypeInference.mli cic_acic/eta_fixing.ml cic_acic/eta_fixing.mli content_pres/.cvsignore content_pres/.depend content_pres/Makefile content_pres/box.ml content_pres/box.mli content_pres/boxPp.ml content_pres/boxPp.mli content_pres/cicNotationLexer.ml content_pres/cicNotationLexer.mli content_pres/cicNotationParser.ml content_pres/cicNotationParser.mli content_pres/cicNotationPres.ml content_pres/cicNotationPres.mli content_pres/content2pres.ml content_pres/content2pres.mli content_pres/content2presMatcher.ml content_pres/content2presMatcher.mli content_pres/mpresentation.ml content_pres/mpresentation.mli content_pres/renderingAttrs.ml content_pres/renderingAttrs.mli content_pres/sequent2pres.ml content_pres/sequent2pres.mli content_pres/termContentPres.ml content_pres/termContentPres.mli content_pres/test_lexer.ml extlib/patternMatcher.ml extlib/patternMatcher.mli grafite/.cvsignore grafite/.depend grafite/Makefile grafite/cicNotation.ml grafite/cicNotation.mli grafite/grafiteAst.ml grafite/grafiteAstPp.ml grafite/grafiteAstPp.mli grafite/grafiteParser.ml grafite/grafiteParser.mli grafite/print_grammar.ml grafite/test_dep.ml grafite/test_parser.ml hgdome/.cvsignore hgdome/.depend hgdome/Makefile hgdome/domMisc.ml hgdome/domMisc.mli hgdome/xml2Gdome.ml hgdome/xml2Gdome.mli Removed Files: METAS/meta.helm-cic_notation.src METAS/meta.helm-cic_omdoc.src METAS/meta.helm-cic_transformations.src cic_disambiguation/disambiguatePp.ml cic_disambiguation/disambiguatePp.mli cic_notation/.cvsignore cic_notation/.depend cic_notation/Makefile cic_notation/TODO cic_notation/box.ml cic_notation/box.mli cic_notation/boxPp.ml cic_notation/boxPp.mli cic_notation/cicNotation.ml cic_notation/cicNotation.mli cic_notation/cicNotationEnv.ml cic_notation/cicNotationEnv.mli cic_notation/cicNotationFwd.ml cic_notation/cicNotationFwd.mli cic_notation/cicNotationLexer.ml cic_notation/cicNotationLexer.mli cic_notation/cicNotationMatcher.ml cic_notation/cicNotationMatcher.mli cic_notation/cicNotationParser.expanded.ml cic_notation/cicNotationParser.ml cic_notation/cicNotationParser.mli cic_notation/cicNotationPp.ml cic_notation/cicNotationPp.mli cic_notation/cicNotationPres.ml cic_notation/cicNotationPres.mli cic_notation/cicNotationPt.ml cic_notation/cicNotationRew.ml cic_notation/cicNotationRew.mli cic_notation/cicNotationTag.ml cic_notation/cicNotationTag.mli cic_notation/cicNotationUtil.ml cic_notation/cicNotationUtil.mli cic_notation/grafiteAst.ml cic_notation/grafiteAstPp.ml cic_notation/grafiteAstPp.mli cic_notation/grafiteParser.ml cic_notation/grafiteParser.mli cic_notation/mpresentation.ml cic_notation/mpresentation.mli cic_notation/print_grammar.ml cic_notation/renderingAttrs.ml cic_notation/renderingAttrs.mli cic_notation/test_dep.ml cic_notation/test_lexer.ml cic_notation/test_parser.conf.xml cic_notation/test_parser.ml cic_notation/doc/.cvsignore cic_notation/doc/Makefile cic_notation/doc/body.tex cic_notation/doc/infernce.sty cic_notation/doc/ligature.sty cic_notation/doc/main.tex cic_notation/doc/manfnt.sty cic_notation/doc/reserved.sty cic_notation/doc/samples.ma cic_notation/doc/semantic.sty cic_notation/doc/shrthand.sty cic_notation/doc/tdiagram.sty cic_omdoc/.cvsignore cic_omdoc/.depend cic_omdoc/Makefile cic_omdoc/cic2acic.ml cic_omdoc/cic2acic.mli cic_omdoc/cic2content.ml cic_omdoc/cic2content.mli cic_omdoc/content.ml cic_omdoc/content.mli cic_omdoc/content2cic.ml cic_omdoc/content2cic.mli cic_omdoc/contentPp.ml cic_omdoc/contentPp.mli cic_omdoc/doubleTypeInference.ml cic_omdoc/doubleTypeInference.mli cic_omdoc/eta_fixing.ml cic_omdoc/eta_fixing.mli cic_transformations/.cvsignore cic_transformations/.depend cic_transformations/Makefile cic_transformations/applyTransformation.ml cic_transformations/applyTransformation.mli cic_transformations/cic2Xml.ml cic_transformations/cic2Xml.mli cic_transformations/content2pres.ml cic_transformations/content2pres.mli cic_transformations/domMisc.ml cic_transformations/domMisc.mli cic_transformations/sequent2pres.ml cic_transformations/sequent2pres.mli cic_transformations/xml2Gdome.ml cic_transformations/xml2Gdome.mli --- diff --git a/helm/ocaml/METAS/meta.helm-acic_content.src b/helm/ocaml/METAS/meta.helm-acic_content.src new file mode 100644 index 000000000..2ffa1551b --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-acic_content.src @@ -0,0 +1,4 @@ +requires="helm-cic_acic" +version="0.0.1" +archive(byte)="acic_content.cma" +archive(native)="acic_content.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-cic_acic.src b/helm/ocaml/METAS/meta.helm-cic_acic.src new file mode 100644 index 000000000..51afe1bda --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-cic_acic.src @@ -0,0 +1,4 @@ +requires="helm-cic_proof_checking" +version="0.0.1" +archive(byte)="cic_acic.cma" +archive(native)="cic_acic.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-cic_disambiguation.src b/helm/ocaml/METAS/meta.helm-cic_disambiguation.src index 1d084c4e3..d0a61cd51 100644 --- a/helm/ocaml/METAS/meta.helm-cic_disambiguation.src +++ b/helm/ocaml/METAS/meta.helm-cic_disambiguation.src @@ -1,4 +1,4 @@ -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" diff --git a/helm/ocaml/METAS/meta.helm-cic_notation.src b/helm/ocaml/METAS/meta.helm-cic_notation.src deleted file mode 100644 index 332714edf..000000000 --- a/helm/ocaml/METAS/meta.helm-cic_notation.src +++ /dev/null @@ -1,4 +0,0 @@ -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" diff --git a/helm/ocaml/METAS/meta.helm-cic_omdoc.src b/helm/ocaml/METAS/meta.helm-cic_omdoc.src deleted file mode 100644 index 313d19cd2..000000000 --- a/helm/ocaml/METAS/meta.helm-cic_omdoc.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-cic_proof_checking" -version="0.0.1" -archive(byte)="cic_omdoc.cma" -archive(native)="cic_omdoc.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-cic_transformations.src b/helm/ocaml/METAS/meta.helm-cic_transformations.src deleted file mode 100644 index 0543f4220..000000000 --- a/helm/ocaml/METAS/meta.helm-cic_transformations.src +++ /dev/null @@ -1,5 +0,0 @@ -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="" diff --git a/helm/ocaml/METAS/meta.helm-content_pres.src b/helm/ocaml/METAS/meta.helm-content_pres.src new file mode 100644 index 000000000..cd3d36854 --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-content_pres.src @@ -0,0 +1,4 @@ +requires="helm-acic_content helm-utf8_macros camlp4.gramlib ulex" +version="0.0.1" +archive(byte)="content_pres.cma" +archive(native)="content_pres.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-grafite.src b/helm/ocaml/METAS/meta.helm-grafite.src new file mode 100644 index 000000000..847d6e333 --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-grafite.src @@ -0,0 +1,4 @@ +requires="helm-content_pres" +version="0.0.1" +archive(byte)="grafite.cma" +archive(native)="grafite.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-hgdome.src b/helm/ocaml/METAS/meta.helm-hgdome.src new file mode 100644 index 000000000..d06666f43 --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-hgdome.src @@ -0,0 +1,4 @@ +requires="helm-xml gdome2" +version="0.0.1" +archive(byte)="hgdome.cma" +archive(native)="hgdome.cmxa" diff --git a/helm/ocaml/Makefile.in b/helm/ocaml/Makefile.in index 4147a9226..30c25dc19 100644 --- a/helm/ocaml/Makefile.in +++ b/helm/ocaml/Makefile.in @@ -3,6 +3,7 @@ NULL = MODULES = \ extlib \ xml \ + hgdome \ registry \ hmysql \ utf8_macros \ @@ -14,12 +15,13 @@ MODULES = \ 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) diff --git a/helm/ocaml/acic_content/.cvsignore b/helm/ocaml/acic_content/.cvsignore new file mode 100644 index 000000000..8d64a5378 --- /dev/null +++ b/helm/ocaml/acic_content/.cvsignore @@ -0,0 +1,2 @@ +*.cm[iaox] +*.cmxa diff --git a/helm/ocaml/acic_content/.depend b/helm/ocaml/acic_content/.depend new file mode 100644 index 000000000..f6399321e --- /dev/null +++ b/helm/ocaml/acic_content/.depend @@ -0,0 +1,30 @@ +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 diff --git a/helm/ocaml/acic_content/Makefile b/helm/ocaml/acic_content/Makefile new file mode 100644 index 000000000..cc4da3781 --- /dev/null +++ b/helm/ocaml/acic_content/Makefile @@ -0,0 +1,19 @@ +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 diff --git a/helm/ocaml/acic_content/acic2astMatcher.ml b/helm/ocaml/acic_content/acic2astMatcher.ml new file mode 100644 index 000000000..7575dc8ba --- /dev/null +++ b/helm/ocaml/acic_content/acic2astMatcher.ml @@ -0,0 +1,96 @@ +(* 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 + diff --git a/helm/ocaml/acic_content/acic2astMatcher.mli b/helm/ocaml/acic_content/acic2astMatcher.mli new file mode 100644 index 000000000..0a9ec6a6b --- /dev/null +++ b/helm/ocaml/acic_content/acic2astMatcher.mli @@ -0,0 +1,34 @@ +(* 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 + diff --git a/helm/ocaml/acic_content/acic2content.ml b/helm/ocaml/acic_content/acic2content.ml new file mode 100644 index 000000000..72699f7e3 --- /dev/null +++ b/helm/ocaml/acic_content/acic2content.ml @@ -0,0 +1,992 @@ +(* 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 *) +(* 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 +*) + + diff --git a/helm/ocaml/acic_content/acic2content.mli b/helm/ocaml/acic_content/acic2content.mli new file mode 100644 index 000000000..e1dfb82de --- /dev/null +++ b/helm/ocaml/acic_content/acic2content.mli @@ -0,0 +1,33 @@ +(* 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 diff --git a/helm/ocaml/acic_content/cicNotationEnv.ml b/helm/ocaml/acic_content/cicNotationEnv.ml new file mode 100644 index 000000000..62212f92f --- /dev/null +++ b/helm/ocaml/acic_content/cicNotationEnv.ml @@ -0,0 +1,151 @@ +(* 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 + diff --git a/helm/ocaml/acic_content/cicNotationEnv.mli b/helm/ocaml/acic_content/cicNotationEnv.mli new file mode 100644 index 000000000..d4f87097e --- /dev/null +++ b/helm/ocaml/acic_content/cicNotationEnv.mli @@ -0,0 +1,92 @@ +(* 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 + diff --git a/helm/ocaml/acic_content/cicNotationPp.ml b/helm/ocaml/acic_content/cicNotationPp.ml new file mode 100644 index 000000000..bf0f9ed4c --- /dev/null +++ b/helm/ocaml/acic_content/cicNotationPp.ml @@ -0,0 +1,321 @@ +(* 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)) + diff --git a/helm/ocaml/acic_content/cicNotationPp.mli b/helm/ocaml/acic_content/cicNotationPp.mli new file mode 100644 index 000000000..57a4d6b82 --- /dev/null +++ b/helm/ocaml/acic_content/cicNotationPp.mli @@ -0,0 +1,37 @@ +(* 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 + diff --git a/helm/ocaml/acic_content/cicNotationPt.ml b/helm/ocaml/acic_content/cicNotationPt.ml new file mode 100644 index 000000000..e3d5fc544 --- /dev/null +++ b/helm/ocaml/acic_content/cicNotationPt.ml @@ -0,0 +1,188 @@ +(* 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, 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 + + (** + * 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 + diff --git a/helm/ocaml/acic_content/cicNotationUtil.ml b/helm/ocaml/acic_content/cicNotationUtil.ml new file mode 100644 index 000000000..0aa6b48b3 --- /dev/null +++ b/helm/ocaml/acic_content/cicNotationUtil.ml @@ -0,0 +1,385 @@ +(* 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 + diff --git a/helm/ocaml/acic_content/cicNotationUtil.mli b/helm/ocaml/acic_content/cicNotationUtil.mli new file mode 100644 index 000000000..5d309d68f --- /dev/null +++ b/helm/ocaml/acic_content/cicNotationUtil.mli @@ -0,0 +1,91 @@ +(* 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 + diff --git a/helm/ocaml/acic_content/content.ml b/helm/ocaml/acic_content/content.ml new file mode 100644 index 000000000..9687e53fc --- /dev/null +++ b/helm/ocaml/acic_content/content.ml @@ -0,0 +1,167 @@ +(* 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 *) +(* 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 *) +;; diff --git a/helm/ocaml/acic_content/content.mli b/helm/ocaml/acic_content/content.mli new file mode 100644 index 000000000..c1122b8f2 --- /dev/null +++ b/helm/ocaml/acic_content/content.mli @@ -0,0 +1,157 @@ +(* 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 *) +;; diff --git a/helm/ocaml/acic_content/content2cic.ml b/helm/ocaml/acic_content/content2cic.ml new file mode 100644 index 000000000..339492d19 --- /dev/null +++ b/helm/ocaml/acic_content/content2cic.ml @@ -0,0 +1,268 @@ +(* 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 *) +(* 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;; diff --git a/helm/ocaml/acic_content/content2cic.mli b/helm/ocaml/acic_content/content2cic.mli new file mode 100644 index 000000000..9bb6509cc --- /dev/null +++ b/helm/ocaml/acic_content/content2cic.mli @@ -0,0 +1,35 @@ +(* 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 *) +(* 27/6/2003 *) +(* *) +(**************************************************************************) + +val cobj2obj : Cic.annterm Content.cobj -> Cic.obj diff --git a/helm/ocaml/acic_content/contentPp.ml b/helm/ocaml/acic_content/contentPp.ml new file mode 100644 index 000000000..3967c6216 --- /dev/null +++ b/helm/ocaml/acic_content/contentPp.ml @@ -0,0 +1,156 @@ +(* 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 *) +(* 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 +;; + + + + + diff --git a/helm/ocaml/acic_content/contentPp.mli b/helm/ocaml/acic_content/contentPp.mli new file mode 100644 index 000000000..a160ab1ff --- /dev/null +++ b/helm/ocaml/acic_content/contentPp.mli @@ -0,0 +1,30 @@ +(* 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 diff --git a/helm/ocaml/acic_content/termAcicContent.ml b/helm/ocaml/acic_content/termAcicContent.ml new file mode 100644 index 000000000..a9cf9a4d1 --- /dev/null +++ b/helm/ocaml/acic_content/termAcicContent.ml @@ -0,0 +1,369 @@ +(* 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 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 + diff --git a/helm/ocaml/acic_content/termAcicContent.mli b/helm/ocaml/acic_content/termAcicContent.mli new file mode 100644 index 000000000..1fd57e0d0 --- /dev/null +++ b/helm/ocaml/acic_content/termAcicContent.mli @@ -0,0 +1,68 @@ +(* 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 + diff --git a/helm/ocaml/cic_acic/.cvsignore b/helm/ocaml/cic_acic/.cvsignore new file mode 100644 index 000000000..8d64a5378 --- /dev/null +++ b/helm/ocaml/cic_acic/.cvsignore @@ -0,0 +1,2 @@ +*.cm[iaox] +*.cmxa diff --git a/helm/ocaml/cic_acic/.depend b/helm/ocaml/cic_acic/.depend new file mode 100644 index 000000000..3fc1e0dce --- /dev/null +++ b/helm/ocaml/cic_acic/.depend @@ -0,0 +1,9 @@ +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 diff --git a/helm/ocaml/cic_acic/Makefile b/helm/ocaml/cic_acic/Makefile new file mode 100644 index 000000000..a7f1e19cf --- /dev/null +++ b/helm/ocaml/cic_acic/Makefile @@ -0,0 +1,12 @@ +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 diff --git a/helm/ocaml/cic_acic/cic2Xml.ml b/helm/ocaml/cic_acic/cic2Xml.ml new file mode 100644 index 000000000..5bd9fd1c9 --- /dev/null +++ b/helm/ocaml/cic_acic/cic2Xml.ml @@ -0,0 +1,479 @@ +(* 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 "\n" ; + X.xml_cdata ("\n"); + xml_for_current_proof_body + >] in + let xmlty = + [< X.xml_cdata "\n" ; + X.xml_cdata ("\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 + "\n" ; + X.xml_cdata + ("\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 "\n" ; + X.xml_cdata ("\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 "\n" ; + X.xml_cdata ("\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 "\n" ; + X.xml_cdata + ("\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 "\n" ; + X.xml_cdata + ("\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 [<>] + ) + >] +;; diff --git a/helm/ocaml/cic_acic/cic2Xml.mli b/helm/ocaml/cic_acic/cic2Xml.mli new file mode 100644 index 000000000..22c5669df --- /dev/null +++ b/helm/ocaml/cic_acic/cic2Xml.mli @@ -0,0 +1,46 @@ +(* 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 + diff --git a/helm/ocaml/cic_acic/cic2acic.ml b/helm/ocaml/cic_acic/cic2acic.ml new file mode 100644 index 000000000..1cdabc09f --- /dev/null +++ b/helm/ocaml/cic_acic/cic2acic.ml @@ -0,0 +1,733 @@ +(* 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) +;; diff --git a/helm/ocaml/cic_acic/cic2acic.mli b/helm/ocaml/cic_acic/cic2acic.mli new file mode 100644 index 000000000..e6379283d --- /dev/null +++ b/helm/ocaml/cic_acic/cic2acic.mli @@ -0,0 +1,61 @@ +(* 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 diff --git a/helm/ocaml/cic_acic/doubleTypeInference.ml b/helm/ocaml/cic_acic/doubleTypeInference.ml new file mode 100644 index 000000000..692872439 --- /dev/null +++ b/helm/ocaml/cic_acic/doubleTypeInference.ml @@ -0,0 +1,752 @@ +(* 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 +;; diff --git a/helm/ocaml/cic_acic/doubleTypeInference.mli b/helm/ocaml/cic_acic/doubleTypeInference.mli new file mode 100644 index 000000000..138aad834 --- /dev/null +++ b/helm/ocaml/cic_acic/doubleTypeInference.mli @@ -0,0 +1,32 @@ +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 diff --git a/helm/ocaml/cic_acic/eta_fixing.ml b/helm/ocaml/cic_acic/eta_fixing.ml new file mode 100644 index 000000000..68dec37d6 --- /dev/null +++ b/helm/ocaml/cic_acic/eta_fixing.ml @@ -0,0 +1,311 @@ +(* 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 +;; diff --git a/helm/ocaml/cic_acic/eta_fixing.mli b/helm/ocaml/cic_acic/eta_fixing.mli new file mode 100644 index 000000000..c6c68119d --- /dev/null +++ b/helm/ocaml/cic_acic/eta_fixing.mli @@ -0,0 +1,28 @@ +(* 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 + + diff --git a/helm/ocaml/cic_disambiguation/.depend b/helm/ocaml/cic_disambiguation/.depend index 555b7438d..ca4124461 100644 --- a/helm/ocaml/cic_disambiguation/.depend +++ b/helm/ocaml/cic_disambiguation/.depend @@ -1,14 +1,9 @@ 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 \ diff --git a/helm/ocaml/cic_disambiguation/Makefile b/helm/ocaml/cic_disambiguation/Makefile index a94d8cebc..729590da5 100644 --- a/helm/ocaml/cic_disambiguation/Makefile +++ b/helm/ocaml/cic_disambiguation/Makefile @@ -4,7 +4,6 @@ NOTATIONS = number INTERFACE_FILES = \ disambiguateTypes.mli \ disambiguateChoices.mli \ - disambiguatePp.mli \ disambiguate.mli IMPLEMENTATION_FILES = \ $(patsubst %.mli, %.ml, $(INTERFACE_FILES)) \ diff --git a/helm/ocaml/cic_disambiguation/disambiguate.ml b/helm/ocaml/cic_disambiguation/disambiguate.ml index 3acfd3904..e69099cb5 100644 --- a/helm/ocaml/cic_disambiguation/disambiguate.ml +++ b/helm/ocaml/cic_disambiguation/disambiguate.ml @@ -364,7 +364,7 @@ let interpretate_obj ~context ~env ~uri ~is_path obj = 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 = @@ -412,7 +412,7 @@ let interpretate_obj ~context ~env ~uri ~is_path obj = ) 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 = @@ -450,7 +450,7 @@ let interpretate_obj ~context ~env ~uri ~is_path obj = 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 @@ -601,12 +601,12 @@ let domain_of_obj ~context ast = 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 @@ -626,7 +626,7 @@ let domain_of_obj ~context ast = 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 @@ -676,7 +676,7 @@ sig 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 * @@ -752,7 +752,7 @@ let refine_profiler = HExtlib.profile "disambiguate_thing.refine_thing" | 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 @@ -942,7 +942,7 @@ in refine_profiler.HExtlib.profile foo () 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 diff --git a/helm/ocaml/cic_disambiguation/disambiguate.mli b/helm/ocaml/cic_disambiguation/disambiguate.mli index e8d21c0cd..bb506e8dc 100644 --- a/helm/ocaml/cic_disambiguation/disambiguate.mli +++ b/helm/ocaml/cic_disambiguation/disambiguate.mli @@ -29,7 +29,7 @@ exception NoWellTypedInterpretation of string Lazy.t list exception PathNotWellFormed val interpretate_path : - context:Cic.name list -> DisambiguateTypes.term -> + context:Cic.name list -> CicNotationPt.term -> Cic.term module type Disambiguator = @@ -45,7 +45,7 @@ sig ?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 * @@ -59,7 +59,7 @@ sig 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 * diff --git a/helm/ocaml/cic_disambiguation/disambiguateChoices.ml b/helm/ocaml/cic_disambiguation/disambiguateChoices.ml index b7f241036..71e320428 100644 --- a/helm/ocaml/cic_disambiguation/disambiguateChoices.ml +++ b/helm/ocaml/cic_disambiguation/disambiguateChoices.ml @@ -54,14 +54,14 @@ let mk_choice (dsc, args, appl_pattern) = 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))) diff --git a/helm/ocaml/cic_disambiguation/disambiguatePp.ml b/helm/ocaml/cic_disambiguation/disambiguatePp.ml deleted file mode 100644 index c3a48e409..000000000 --- a/helm/ocaml/cic_disambiguation/disambiguatePp.ml +++ /dev/null @@ -1,83 +0,0 @@ -(* 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) diff --git a/helm/ocaml/cic_disambiguation/disambiguatePp.mli b/helm/ocaml/cic_disambiguation/disambiguatePp.mli deleted file mode 100644 index 69b6e8451..000000000 --- a/helm/ocaml/cic_disambiguation/disambiguatePp.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* 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 diff --git a/helm/ocaml/cic_disambiguation/disambiguateTypes.ml b/helm/ocaml/cic_disambiguation/disambiguateTypes.ml index b323f9231..c22f08ed7 100644 --- a/helm/ocaml/cic_disambiguation/disambiguateTypes.ml +++ b/helm/ocaml/cic_disambiguation/disambiguateTypes.ml @@ -23,6 +23,7 @@ * 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 @@ -30,6 +31,7 @@ type script_entry = | Command of tactical | Comment of CicNotationPt.location * string type script = CicNotationPt.location * script_entry list +*) type domain_item = | Id of string (* literal *) diff --git a/helm/ocaml/cic_disambiguation/disambiguateTypes.mli b/helm/ocaml/cic_disambiguation/disambiguateTypes.mli index 4d077f2f8..48ae7880d 100644 --- a/helm/ocaml/cic_disambiguation/disambiguateTypes.mli +++ b/helm/ocaml/cic_disambiguation/disambiguateTypes.mli @@ -84,6 +84,7 @@ val string_of_domain: domain_item list -> string (** {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 @@ -92,6 +93,7 @@ type script_entry = | Command of tactical | Comment of CicNotationPt.location * string type script = CicNotationPt.location * script_entry list +*) val dummy_floc: Lexing.position * Lexing.position diff --git a/helm/ocaml/cic_notation/.cvsignore b/helm/ocaml/cic_notation/.cvsignore deleted file mode 100644 index 45ec2c22f..000000000 --- a/helm/ocaml/cic_notation/.cvsignore +++ /dev/null @@ -1,7 +0,0 @@ -*.cm[aiox] -*.cmxa -*.[ao] -test_lexer -test_parser -test_dep -print_grammar diff --git a/helm/ocaml/cic_notation/.depend b/helm/ocaml/cic_notation/.depend deleted file mode 100644 index c19c9ea3c..000000000 --- a/helm/ocaml/cic_notation/.depend +++ /dev/null @@ -1,73 +0,0 @@ -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 diff --git a/helm/ocaml/cic_notation/Makefile b/helm/ocaml/cic_notation/Makefile deleted file mode 100644 index 21c9a4e8c..000000000 --- a/helm/ocaml/cic_notation/Makefile +++ /dev/null @@ -1,67 +0,0 @@ - -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' $< > $@ - diff --git a/helm/ocaml/cic_notation/TODO b/helm/ocaml/cic_notation/TODO deleted file mode 100644 index a98131c07..000000000 --- a/helm/ocaml/cic_notation/TODO +++ /dev/null @@ -1,47 +0,0 @@ - -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 - diff --git a/helm/ocaml/cic_notation/box.ml b/helm/ocaml/cic_notation/box.ml deleted file mode 100644 index c11558a27..000000000 --- a/helm/ocaml/cic_notation/box.ml +++ /dev/null @@ -1,150 +0,0 @@ -(* 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 *) -(* 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 "\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) - diff --git a/helm/ocaml/cic_notation/box.mli b/helm/ocaml/cic_notation/box.mli deleted file mode 100644 index 56c086964..000000000 --- a/helm/ocaml/cic_notation/box.mli +++ /dev/null @@ -1,78 +0,0 @@ -(* 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 *) -(* 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 - diff --git a/helm/ocaml/cic_notation/boxPp.ml b/helm/ocaml/cic_notation/boxPp.ml deleted file mode 100644 index ddb9d3b82..000000000 --- a/helm/ocaml/cic_notation/boxPp.ml +++ /dev/null @@ -1,239 +0,0 @@ -(* 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) - diff --git a/helm/ocaml/cic_notation/boxPp.mli b/helm/ocaml/cic_notation/boxPp.mli deleted file mode 100644 index 6b7c3cec8..000000000 --- a/helm/ocaml/cic_notation/boxPp.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotation.ml b/helm/ocaml/cic_notation/cicNotation.ml deleted file mode 100644 index cbad3391f..000000000 --- a/helm/ocaml/cic_notation/cicNotation.ml +++ /dev/null @@ -1,90 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotation.mli b/helm/ocaml/cic_notation/cicNotation.mli deleted file mode 100644 index 1c6e95385..000000000 --- a/helm/ocaml/cic_notation/cicNotation.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotationEnv.ml b/helm/ocaml/cic_notation/cicNotationEnv.ml deleted file mode 100644 index 62212f92f..000000000 --- a/helm/ocaml/cic_notation/cicNotationEnv.ml +++ /dev/null @@ -1,151 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotationEnv.mli b/helm/ocaml/cic_notation/cicNotationEnv.mli deleted file mode 100644 index d4f87097e..000000000 --- a/helm/ocaml/cic_notation/cicNotationEnv.mli +++ /dev/null @@ -1,92 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotationFwd.ml b/helm/ocaml/cic_notation/cicNotationFwd.ml deleted file mode 100644 index bf4b3e38e..000000000 --- a/helm/ocaml/cic_notation/cicNotationFwd.ml +++ /dev/null @@ -1,218 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotationFwd.mli b/helm/ocaml/cic_notation/cicNotationFwd.mli deleted file mode 100644 index 4a5d89f98..000000000 --- a/helm/ocaml/cic_notation/cicNotationFwd.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotationLexer.ml b/helm/ocaml/cic_notation/cicNotationLexer.ml deleted file mode 100644 index 33fb8fd78..000000000 --- a/helm/ocaml/cic_notation/cicNotationLexer.ml +++ /dev/null @@ -1,351 +0,0 @@ -(* 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>); ("=>", <:unicode>); - ("<=", <:unicode>); (">=", <:unicode>); - ("<>", <:unicode>); (":=", <:unicode>); - ] - -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 -> [] - diff --git a/helm/ocaml/cic_notation/cicNotationLexer.mli b/helm/ocaml/cic_notation/cicNotationLexer.mli deleted file mode 100644 index cd5f0876d..000000000 --- a/helm/ocaml/cic_notation/cicNotationLexer.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotationMatcher.ml b/helm/ocaml/cic_notation/cicNotationMatcher.ml deleted file mode 100644 index 7b85b96b5..000000000 --- a/helm/ocaml/cic_notation/cicNotationMatcher.ml +++ /dev/null @@ -1,448 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotationMatcher.mli b/helm/ocaml/cic_notation/cicNotationMatcher.mli deleted file mode 100644 index f8daca798..000000000 --- a/helm/ocaml/cic_notation/cicNotationMatcher.mli +++ /dev/null @@ -1,79 +0,0 @@ -(* 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 ) - * @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 - diff --git a/helm/ocaml/cic_notation/cicNotationParser.expanded.ml b/helm/ocaml/cic_notation/cicNotationParser.expanded.ml deleted file mode 100644 index 9d0b57940..000000000 --- a/helm/ocaml/cic_notation/cicNotationParser.expanded.ml +++ /dev/null @@ -1,1162 +0,0 @@ -(* *)(* 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: *) diff --git a/helm/ocaml/cic_notation/cicNotationParser.ml b/helm/ocaml/cic_notation/cicNotationParser.ml deleted file mode 100644 index 71cc2bffd..000000000 --- a/helm/ocaml/cic_notation/cicNotationParser.ml +++ /dev/null @@ -1,645 +0,0 @@ -(* 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> (* ≔ *); 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 -(* | SYMBOL <:unicode> |+ ∃ +| -> `Exists *) - | SYMBOL <:unicode> (* ∀ *) -> `Forall - | SYMBOL <:unicode> (* λ *) -> `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> (* ≝ *); 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> (* ≝ *); - 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> (* ∃ *); - (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> (* ⇒ *); - 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: *) diff --git a/helm/ocaml/cic_notation/cicNotationParser.mli b/helm/ocaml/cic_notation/cicNotationParser.mli deleted file mode 100644 index e25968bbb..000000000 --- a/helm/ocaml/cic_notation/cicNotationParser.mli +++ /dev/null @@ -1,66 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotationPp.ml b/helm/ocaml/cic_notation/cicNotationPp.ml deleted file mode 100644 index b5a2e04f2..000000000 --- a/helm/ocaml/cic_notation/cicNotationPp.ml +++ /dev/null @@ -1,259 +0,0 @@ -(* 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) - diff --git a/helm/ocaml/cic_notation/cicNotationPp.mli b/helm/ocaml/cic_notation/cicNotationPp.mli deleted file mode 100644 index 2fb05c51b..000000000 --- a/helm/ocaml/cic_notation/cicNotationPp.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotationPres.ml b/helm/ocaml/cic_notation/cicNotationPres.ml deleted file mode 100644 index cc3a204a4..000000000 --- a/helm/ocaml/cic_notation/cicNotationPres.ml +++ /dev/null @@ -1,427 +0,0 @@ -(* 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 *) - diff --git a/helm/ocaml/cic_notation/cicNotationPres.mli b/helm/ocaml/cic_notation/cicNotationPres.mli deleted file mode 100644 index 04411df2b..000000000 --- a/helm/ocaml/cic_notation/cicNotationPres.mli +++ /dev/null @@ -1,52 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotationPt.ml b/helm/ocaml/cic_notation/cicNotationPt.ml deleted file mode 100644 index d0310d0e5..000000000 --- a/helm/ocaml/cic_notation/cicNotationPt.ml +++ /dev/null @@ -1,171 +0,0 @@ -(* 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, 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 - diff --git a/helm/ocaml/cic_notation/cicNotationRew.ml b/helm/ocaml/cic_notation/cicNotationRew.ml deleted file mode 100644 index 8bbc22e24..000000000 --- a/helm/ocaml/cic_notation/cicNotationRew.ml +++ /dev/null @@ -1,780 +0,0 @@ -(* 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 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 [] - diff --git a/helm/ocaml/cic_notation/cicNotationRew.mli b/helm/ocaml/cic_notation/cicNotationRew.mli deleted file mode 100644 index f587291aa..000000000 --- a/helm/ocaml/cic_notation/cicNotationRew.mli +++ /dev/null @@ -1,74 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotationTag.ml b/helm/ocaml/cic_notation/cicNotationTag.ml deleted file mode 100644 index 3cbffa2db..000000000 --- a/helm/ocaml/cic_notation/cicNotationTag.ml +++ /dev/null @@ -1,45 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotationTag.mli b/helm/ocaml/cic_notation/cicNotationTag.mli deleted file mode 100644 index bf04e0a9f..000000000 --- a/helm/ocaml/cic_notation/cicNotationTag.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotationUtil.ml b/helm/ocaml/cic_notation/cicNotationUtil.ml deleted file mode 100644 index 887f5bf05..000000000 --- a/helm/ocaml/cic_notation/cicNotationUtil.ml +++ /dev/null @@ -1,385 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/cicNotationUtil.mli b/helm/ocaml/cic_notation/cicNotationUtil.mli deleted file mode 100644 index ad16a2eb6..000000000 --- a/helm/ocaml/cic_notation/cicNotationUtil.mli +++ /dev/null @@ -1,91 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/doc/.cvsignore b/helm/ocaml/cic_notation/doc/.cvsignore deleted file mode 100644 index 583537c57..000000000 --- a/helm/ocaml/cic_notation/doc/.cvsignore +++ /dev/null @@ -1,6 +0,0 @@ -main.aux -main.dvi -main.log -main.out -main.pdf -main.ps diff --git a/helm/ocaml/cic_notation/doc/Makefile b/helm/ocaml/cic_notation/doc/Makefile deleted file mode 100644 index b7d8fb45c..000000000 --- a/helm/ocaml/cic_notation/doc/Makefile +++ /dev/null @@ -1,124 +0,0 @@ - -# -# Generic makefile for latex -# -# Author: Stefano Zacchiroli -# -# 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 - -######################################################################## - diff --git a/helm/ocaml/cic_notation/doc/body.tex b/helm/ocaml/cic_notation/doc/body.tex deleted file mode 100644 index fef547e1d..000000000 --- a/helm/ocaml/cic_notation/doc/body.tex +++ /dev/null @@ -1,1225 +0,0 @@ - -\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} - diff --git a/helm/ocaml/cic_notation/doc/infernce.sty b/helm/ocaml/cic_notation/doc/infernce.sty deleted file mode 100644 index fc4afeaaf..000000000 --- a/helm/ocaml/cic_notation/doc/infernce.sty +++ /dev/null @@ -1,217 +0,0 @@ -%% -%% 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 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'. diff --git a/helm/ocaml/cic_notation/doc/ligature.sty b/helm/ocaml/cic_notation/doc/ligature.sty deleted file mode 100644 index a914d91d1..000000000 --- a/helm/ocaml/cic_notation/doc/ligature.sty +++ /dev/null @@ -1,169 +0,0 @@ -%% -%% 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 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'. diff --git a/helm/ocaml/cic_notation/doc/main.tex b/helm/ocaml/cic_notation/doc/main.tex deleted file mode 100644 index 36d35026c..000000000 --- a/helm/ocaml/cic_notation/doc/main.tex +++ /dev/null @@ -1,43 +0,0 @@ -\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} - diff --git a/helm/ocaml/cic_notation/doc/manfnt.sty b/helm/ocaml/cic_notation/doc/manfnt.sty deleted file mode 100644 index c332cc6fc..000000000 --- a/helm/ocaml/cic_notation/doc/manfnt.sty +++ /dev/null @@ -1,74 +0,0 @@ -%% -%% 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'. diff --git a/helm/ocaml/cic_notation/doc/reserved.sty b/helm/ocaml/cic_notation/doc/reserved.sty deleted file mode 100644 index c0d56b8aa..000000000 --- a/helm/ocaml/cic_notation/doc/reserved.sty +++ /dev/null @@ -1,80 +0,0 @@ -%% -%% 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 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 to proceed --- nothing will be set.}}% - {\reserved@a}} -\let\<=\setreserved -\fi -\endinput -%% -%% End of file `reserved.sty'. diff --git a/helm/ocaml/cic_notation/doc/samples.ma b/helm/ocaml/cic_notation/doc/samples.ma deleted file mode 100644 index ff6380151..000000000 --- a/helm/ocaml/cic_notation/doc/samples.ma +++ /dev/null @@ -1,139 +0,0 @@ - -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 \]. - - diff --git a/helm/ocaml/cic_notation/doc/semantic.sty b/helm/ocaml/cic_notation/doc/semantic.sty deleted file mode 100644 index 98257cab8..000000000 --- a/helm/ocaml/cic_notation/doc/semantic.sty +++ /dev/null @@ -1,137 +0,0 @@ -%% -%% 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 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'. diff --git a/helm/ocaml/cic_notation/doc/shrthand.sty b/helm/ocaml/cic_notation/doc/shrthand.sty deleted file mode 100644 index b73af4470..000000000 --- a/helm/ocaml/cic_notation/doc/shrthand.sty +++ /dev/null @@ -1,96 +0,0 @@ -%% -%% 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 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'. diff --git a/helm/ocaml/cic_notation/doc/tdiagram.sty b/helm/ocaml/cic_notation/doc/tdiagram.sty deleted file mode 100644 index 02202b34a..000000000 --- a/helm/ocaml/cic_notation/doc/tdiagram.sty +++ /dev/null @@ -1,166 +0,0 @@ -%% -%% 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 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 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 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'. diff --git a/helm/ocaml/cic_notation/grafiteAst.ml b/helm/ocaml/cic_notation/grafiteAst.ml deleted file mode 100644 index cba5acd1f..000000000 --- a/helm/ocaml/cic_notation/grafiteAst.ml +++ /dev/null @@ -1,249 +0,0 @@ -(* 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 - - (** - * 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 - diff --git a/helm/ocaml/cic_notation/grafiteAstPp.ml b/helm/ocaml/cic_notation/grafiteAstPp.ml deleted file mode 100644 index 3e19ed281..000000000 --- a/helm/ocaml/cic_notation/grafiteAstPp.ml +++ /dev/null @@ -1,366 +0,0 @@ -(* 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 ^ "\"" - diff --git a/helm/ocaml/cic_notation/grafiteAstPp.mli b/helm/ocaml/cic_notation/grafiteAstPp.mli deleted file mode 100644 index b8445095f..000000000 --- a/helm/ocaml/cic_notation/grafiteAstPp.mli +++ /dev/null @@ -1,69 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/grafiteParser.ml b/helm/ocaml/cic_notation/grafiteParser.ml deleted file mode 100644 index e7c54213d..000000000 --- a/helm/ocaml/cic_notation/grafiteParser.ml +++ /dev/null @@ -1,559 +0,0 @@ -(* 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>; 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> ; 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>; OPT SYMBOL "|"; - fst_constructors = LIST0 constructor SEP SYMBOL "|"; - tl = OPT [ "with"; - types = LIST1 [ - name = IDENT; SYMBOL ":"; typ = term; SYMBOL <:unicode>; - 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>; 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> (* η *); 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> ; 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> (* ≝ *); body = term -> body ] -> - GrafiteAst.Obj (loc,GrafiteAst.Theorem (flavour, name, typ, body)) - | flavour = theorem_flavour; name = IDENT; SYMBOL <:unicode> (* ≝ *); - 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 []) - diff --git a/helm/ocaml/cic_notation/grafiteParser.mli b/helm/ocaml/cic_notation/grafiteParser.mli deleted file mode 100644 index fa732218f..000000000 --- a/helm/ocaml/cic_notation/grafiteParser.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/mpresentation.ml b/helm/ocaml/cic_notation/mpresentation.ml deleted file mode 100644 index 1303d1eb7..000000000 --- a/helm/ocaml/cic_notation/mpresentation.ml +++ /dev/null @@ -1,256 +0,0 @@ -(* 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 *) -(* 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 "\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) - diff --git a/helm/ocaml/cic_notation/mpresentation.mli b/helm/ocaml/cic_notation/mpresentation.mli deleted file mode 100644 index 8252517a6..000000000 --- a/helm/ocaml/cic_notation/mpresentation.mli +++ /dev/null @@ -1,86 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/print_grammar.ml b/helm/ocaml/cic_notation/print_grammar.ml deleted file mode 100644 index d7d6f3c96..000000000 --- a/helm/ocaml/cic_notation/print_grammar.ml +++ /dev/null @@ -1,285 +0,0 @@ -(* 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 "@["; - 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 "{@[ "; - let todo = visit_symbol symbol todo is_son (nesting+1) in - Format.fprintf fmt "@]} @ "; - todo - | Slist0sep (symbol,sep) -> - Format.fprintf fmt "[@[ "; - let todo = visit_symbol symbol todo is_son (nesting + 1) in - Format.fprintf fmt "{@[ "; - 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 "{@[ "; - 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 "{@[ "; - 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 "[@[ "; - 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 "@[( "; - 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 "@[%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] [] diff --git a/helm/ocaml/cic_notation/renderingAttrs.ml b/helm/ocaml/cic_notation/renderingAttrs.ml deleted file mode 100644 index 478ceff95..000000000 --- a/helm/ocaml/cic_notation/renderingAttrs.ml +++ /dev/null @@ -1,48 +0,0 @@ -(* 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" ] - diff --git a/helm/ocaml/cic_notation/renderingAttrs.mli b/helm/ocaml/cic_notation/renderingAttrs.mli deleted file mode 100644 index 64323598b..000000000 --- a/helm/ocaml/cic_notation/renderingAttrs.mli +++ /dev/null @@ -1,57 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/test_dep.ml b/helm/ocaml/cic_notation/test_dep.ml deleted file mode 100644 index a2c7e392e..000000000 --- a/helm/ocaml/cic_notation/test_dep.ml +++ /dev/null @@ -1,38 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_notation/test_lexer.ml b/helm/ocaml/cic_notation/test_lexer.ml deleted file mode 100644 index 569e86e44..000000000 --- a/helm/ocaml/cic_notation/test_lexer.ml +++ /dev/null @@ -1,58 +0,0 @@ -(* 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 -> () - diff --git a/helm/ocaml/cic_notation/test_parser.conf.xml b/helm/ocaml/cic_notation/test_parser.conf.xml deleted file mode 100644 index 67b5dbefd..000000000 --- a/helm/ocaml/cic_notation/test_parser.conf.xml +++ /dev/null @@ -1,15 +0,0 @@ - -
- - cic:/ - file:///projects/helm/library/coq_contribs/ - - - cic:/matita/ - file:///home/zacchiro/helm/matita/.matita/xml/matita/ - -
-
- ../../matita/core_notation.moo -
- diff --git a/helm/ocaml/cic_notation/test_parser.ml b/helm/ocaml/cic_notation/test_parser.ml deleted file mode 100644 index 0dc914156..000000000 --- a/helm/ocaml/cic_notation/test_parser.ml +++ /dev/null @@ -1,161 +0,0 @@ -(* 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%s%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) - diff --git a/helm/ocaml/cic_omdoc/.cvsignore b/helm/ocaml/cic_omdoc/.cvsignore deleted file mode 100644 index 6b3eba302..000000000 --- a/helm/ocaml/cic_omdoc/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -*.cm[iaox] *.cmxa diff --git a/helm/ocaml/cic_omdoc/.depend b/helm/ocaml/cic_omdoc/.depend deleted file mode 100644 index 2074968ba..000000000 --- a/helm/ocaml/cic_omdoc/.depend +++ /dev/null @@ -1,17 +0,0 @@ -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 diff --git a/helm/ocaml/cic_omdoc/Makefile b/helm/ocaml/cic_omdoc/Makefile deleted file mode 100644 index f4c3b5b6f..000000000 --- a/helm/ocaml/cic_omdoc/Makefile +++ /dev/null @@ -1,18 +0,0 @@ -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 diff --git a/helm/ocaml/cic_omdoc/cic2acic.ml b/helm/ocaml/cic_omdoc/cic2acic.ml deleted file mode 100644 index 1cdabc09f..000000000 --- a/helm/ocaml/cic_omdoc/cic2acic.ml +++ /dev/null @@ -1,733 +0,0 @@ -(* 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) -;; diff --git a/helm/ocaml/cic_omdoc/cic2acic.mli b/helm/ocaml/cic_omdoc/cic2acic.mli deleted file mode 100644 index e6379283d..000000000 --- a/helm/ocaml/cic_omdoc/cic2acic.mli +++ /dev/null @@ -1,61 +0,0 @@ -(* 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 diff --git a/helm/ocaml/cic_omdoc/cic2content.ml b/helm/ocaml/cic_omdoc/cic2content.ml deleted file mode 100644 index 72699f7e3..000000000 --- a/helm/ocaml/cic_omdoc/cic2content.ml +++ /dev/null @@ -1,992 +0,0 @@ -(* 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 *) -(* 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 -*) - - diff --git a/helm/ocaml/cic_omdoc/cic2content.mli b/helm/ocaml/cic_omdoc/cic2content.mli deleted file mode 100644 index e1dfb82de..000000000 --- a/helm/ocaml/cic_omdoc/cic2content.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* 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 diff --git a/helm/ocaml/cic_omdoc/content.ml b/helm/ocaml/cic_omdoc/content.ml deleted file mode 100644 index 9687e53fc..000000000 --- a/helm/ocaml/cic_omdoc/content.ml +++ /dev/null @@ -1,167 +0,0 @@ -(* 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 *) -(* 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 *) -;; diff --git a/helm/ocaml/cic_omdoc/content.mli b/helm/ocaml/cic_omdoc/content.mli deleted file mode 100644 index c1122b8f2..000000000 --- a/helm/ocaml/cic_omdoc/content.mli +++ /dev/null @@ -1,157 +0,0 @@ -(* 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 *) -;; diff --git a/helm/ocaml/cic_omdoc/content2cic.ml b/helm/ocaml/cic_omdoc/content2cic.ml deleted file mode 100644 index 339492d19..000000000 --- a/helm/ocaml/cic_omdoc/content2cic.ml +++ /dev/null @@ -1,268 +0,0 @@ -(* 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 *) -(* 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;; diff --git a/helm/ocaml/cic_omdoc/content2cic.mli b/helm/ocaml/cic_omdoc/content2cic.mli deleted file mode 100644 index 9bb6509cc..000000000 --- a/helm/ocaml/cic_omdoc/content2cic.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* 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 *) -(* 27/6/2003 *) -(* *) -(**************************************************************************) - -val cobj2obj : Cic.annterm Content.cobj -> Cic.obj diff --git a/helm/ocaml/cic_omdoc/contentPp.ml b/helm/ocaml/cic_omdoc/contentPp.ml deleted file mode 100644 index 3967c6216..000000000 --- a/helm/ocaml/cic_omdoc/contentPp.ml +++ /dev/null @@ -1,156 +0,0 @@ -(* 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 *) -(* 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 -;; - - - - - diff --git a/helm/ocaml/cic_omdoc/contentPp.mli b/helm/ocaml/cic_omdoc/contentPp.mli deleted file mode 100644 index a160ab1ff..000000000 --- a/helm/ocaml/cic_omdoc/contentPp.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* 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 diff --git a/helm/ocaml/cic_omdoc/doubleTypeInference.ml b/helm/ocaml/cic_omdoc/doubleTypeInference.ml deleted file mode 100644 index 692872439..000000000 --- a/helm/ocaml/cic_omdoc/doubleTypeInference.ml +++ /dev/null @@ -1,752 +0,0 @@ -(* 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 -;; diff --git a/helm/ocaml/cic_omdoc/doubleTypeInference.mli b/helm/ocaml/cic_omdoc/doubleTypeInference.mli deleted file mode 100644 index 138aad834..000000000 --- a/helm/ocaml/cic_omdoc/doubleTypeInference.mli +++ /dev/null @@ -1,32 +0,0 @@ -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 diff --git a/helm/ocaml/cic_omdoc/eta_fixing.ml b/helm/ocaml/cic_omdoc/eta_fixing.ml deleted file mode 100644 index 68dec37d6..000000000 --- a/helm/ocaml/cic_omdoc/eta_fixing.ml +++ /dev/null @@ -1,311 +0,0 @@ -(* 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 -;; diff --git a/helm/ocaml/cic_omdoc/eta_fixing.mli b/helm/ocaml/cic_omdoc/eta_fixing.mli deleted file mode 100644 index c6c68119d..000000000 --- a/helm/ocaml/cic_omdoc/eta_fixing.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* 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 - - diff --git a/helm/ocaml/cic_transformations/.cvsignore b/helm/ocaml/cic_transformations/.cvsignore deleted file mode 100644 index 6b3eba302..000000000 --- a/helm/ocaml/cic_transformations/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -*.cm[iaox] *.cmxa diff --git a/helm/ocaml/cic_transformations/.depend b/helm/ocaml/cic_transformations/.depend deleted file mode 100644 index 3510045e9..000000000 --- a/helm/ocaml/cic_transformations/.depend +++ /dev/null @@ -1,14 +0,0 @@ -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 diff --git a/helm/ocaml/cic_transformations/Makefile b/helm/ocaml/cic_transformations/Makefile deleted file mode 100644 index c5b5eaf09..000000000 --- a/helm/ocaml/cic_transformations/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -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 diff --git a/helm/ocaml/cic_transformations/applyTransformation.ml b/helm/ocaml/cic_transformations/applyTransformation.ml deleted file mode 100644 index 54402e0bc..000000000 --- a/helm/ocaml/cic_transformations/applyTransformation.ml +++ /dev/null @@ -1,70 +0,0 @@ -(* 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 *) -(* 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))) - diff --git a/helm/ocaml/cic_transformations/applyTransformation.mli b/helm/ocaml/cic_transformations/applyTransformation.mli deleted file mode 100644 index 8e023aea6..000000000 --- a/helm/ocaml/cic_transformations/applyTransformation.mli +++ /dev/null @@ -1,57 +0,0 @@ -(* 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 *) -(* 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 *) - diff --git a/helm/ocaml/cic_transformations/cic2Xml.ml b/helm/ocaml/cic_transformations/cic2Xml.ml deleted file mode 100644 index 5bd9fd1c9..000000000 --- a/helm/ocaml/cic_transformations/cic2Xml.ml +++ /dev/null @@ -1,479 +0,0 @@ -(* 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 "\n" ; - X.xml_cdata ("\n"); - xml_for_current_proof_body - >] in - let xmlty = - [< X.xml_cdata "\n" ; - X.xml_cdata ("\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 - "\n" ; - X.xml_cdata - ("\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 "\n" ; - X.xml_cdata ("\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 "\n" ; - X.xml_cdata ("\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 "\n" ; - X.xml_cdata - ("\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 "\n" ; - X.xml_cdata - ("\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 [<>] - ) - >] -;; diff --git a/helm/ocaml/cic_transformations/cic2Xml.mli b/helm/ocaml/cic_transformations/cic2Xml.mli deleted file mode 100644 index 22c5669df..000000000 --- a/helm/ocaml/cic_transformations/cic2Xml.mli +++ /dev/null @@ -1,46 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/cic_transformations/content2pres.ml b/helm/ocaml/cic_transformations/content2pres.ml deleted file mode 100644 index ee3e64bd5..000000000 --- a/helm/ocaml/cic_transformations/content2pres.ml +++ /dev/null @@ -1,823 +0,0 @@ -(* 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 *) -(* 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))) - diff --git a/helm/ocaml/cic_transformations/content2pres.mli b/helm/ocaml/cic_transformations/content2pres.mli deleted file mode 100644 index 793c31a4f..000000000 --- a/helm/ocaml/cic_transformations/content2pres.mli +++ /dev/null @@ -1,39 +0,0 @@ -(* 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 *) -(* 27/6/2003 *) -(* *) -(**************************************************************************) - -val content2pres: - ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t -> - Cic.annterm Content.cobj -> - CicNotationPres.boxml_markup - diff --git a/helm/ocaml/cic_transformations/domMisc.ml b/helm/ocaml/cic_transformations/domMisc.ml deleted file mode 100644 index 56d542556..000000000 --- a/helm/ocaml/cic_transformations/domMisc.ml +++ /dev/null @@ -1,49 +0,0 @@ -(* 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 *) -(* 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 - diff --git a/helm/ocaml/cic_transformations/domMisc.mli b/helm/ocaml/cic_transformations/domMisc.mli deleted file mode 100644 index d0779d1e7..000000000 --- a/helm/ocaml/cic_transformations/domMisc.mli +++ /dev/null @@ -1,46 +0,0 @@ -(* 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 *) -(* 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 - diff --git a/helm/ocaml/cic_transformations/sequent2pres.ml b/helm/ocaml/cic_transformations/sequent2pres.ml deleted file mode 100644 index b7de8499a..000000000 --- a/helm/ocaml/cic_transformations/sequent2pres.ml +++ /dev/null @@ -1,104 +0,0 @@ -(* 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 *) -(* 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))) - diff --git a/helm/ocaml/cic_transformations/sequent2pres.mli b/helm/ocaml/cic_transformations/sequent2pres.mli deleted file mode 100644 index 615c8e35f..000000000 --- a/helm/ocaml/cic_transformations/sequent2pres.mli +++ /dev/null @@ -1,39 +0,0 @@ -(* 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 *) -(* 19/11/2003 *) -(* *) -(***************************************************************************) - -val sequent2pres : - ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t -> - Cic.annterm Content.conjecture -> - CicNotationPres.boxml_markup - diff --git a/helm/ocaml/cic_transformations/xml2Gdome.ml b/helm/ocaml/cic_transformations/xml2Gdome.ml deleted file mode 100644 index 3d07bf21c..000000000 --- a/helm/ocaml/cic_transformations/xml2Gdome.ml +++ /dev/null @@ -1,133 +0,0 @@ -(* 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 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 -;; diff --git a/helm/ocaml/cic_transformations/xml2Gdome.mli b/helm/ocaml/cic_transformations/xml2Gdome.mli deleted file mode 100644 index 45d0e9532..000000000 --- a/helm/ocaml/cic_transformations/xml2Gdome.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* 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 diff --git a/helm/ocaml/content_pres/.cvsignore b/helm/ocaml/content_pres/.cvsignore new file mode 100644 index 000000000..ce13c765e --- /dev/null +++ b/helm/ocaml/content_pres/.cvsignore @@ -0,0 +1,4 @@ +*.cm[iaox] +*.cmxa +test_lexer +test_lexer.opt diff --git a/helm/ocaml/content_pres/.depend b/helm/ocaml/content_pres/.depend new file mode 100644 index 000000000..781c9e45b --- /dev/null +++ b/helm/ocaml/content_pres/.depend @@ -0,0 +1,36 @@ +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 diff --git a/helm/ocaml/content_pres/Makefile b/helm/ocaml/content_pres/Makefile new file mode 100644 index 000000000..6816a9c24 --- /dev/null +++ b/helm/ocaml/content_pres/Makefile @@ -0,0 +1,42 @@ +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 diff --git a/helm/ocaml/content_pres/box.ml b/helm/ocaml/content_pres/box.ml new file mode 100644 index 000000000..c11558a27 --- /dev/null +++ b/helm/ocaml/content_pres/box.ml @@ -0,0 +1,150 @@ +(* 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 *) +(* 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 "\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) + diff --git a/helm/ocaml/content_pres/box.mli b/helm/ocaml/content_pres/box.mli new file mode 100644 index 000000000..56c086964 --- /dev/null +++ b/helm/ocaml/content_pres/box.mli @@ -0,0 +1,78 @@ +(* 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 *) +(* 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 + diff --git a/helm/ocaml/content_pres/boxPp.ml b/helm/ocaml/content_pres/boxPp.ml new file mode 100644 index 000000000..ddb9d3b82 --- /dev/null +++ b/helm/ocaml/content_pres/boxPp.ml @@ -0,0 +1,239 @@ +(* 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) + diff --git a/helm/ocaml/content_pres/boxPp.mli b/helm/ocaml/content_pres/boxPp.mli new file mode 100644 index 000000000..6b7c3cec8 --- /dev/null +++ b/helm/ocaml/content_pres/boxPp.mli @@ -0,0 +1,33 @@ +(* 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 + diff --git a/helm/ocaml/content_pres/cicNotationLexer.ml b/helm/ocaml/content_pres/cicNotationLexer.ml new file mode 100644 index 000000000..33fb8fd78 --- /dev/null +++ b/helm/ocaml/content_pres/cicNotationLexer.ml @@ -0,0 +1,351 @@ +(* 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>); ("=>", <:unicode>); + ("<=", <:unicode>); (">=", <:unicode>); + ("<>", <:unicode>); (":=", <:unicode>); + ] + +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 -> [] + diff --git a/helm/ocaml/content_pres/cicNotationLexer.mli b/helm/ocaml/content_pres/cicNotationLexer.mli new file mode 100644 index 000000000..cd5f0876d --- /dev/null +++ b/helm/ocaml/content_pres/cicNotationLexer.mli @@ -0,0 +1,48 @@ +(* 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 + diff --git a/helm/ocaml/content_pres/cicNotationParser.ml b/helm/ocaml/content_pres/cicNotationParser.ml new file mode 100644 index 000000000..71cc2bffd --- /dev/null +++ b/helm/ocaml/content_pres/cicNotationParser.ml @@ -0,0 +1,645 @@ +(* 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> (* ≔ *); 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 +(* | SYMBOL <:unicode> |+ ∃ +| -> `Exists *) + | SYMBOL <:unicode> (* ∀ *) -> `Forall + | SYMBOL <:unicode> (* λ *) -> `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> (* ≝ *); 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> (* ≝ *); + 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> (* ∃ *); + (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> (* ⇒ *); + 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: *) diff --git a/helm/ocaml/content_pres/cicNotationParser.mli b/helm/ocaml/content_pres/cicNotationParser.mli new file mode 100644 index 000000000..e25968bbb --- /dev/null +++ b/helm/ocaml/content_pres/cicNotationParser.mli @@ -0,0 +1,66 @@ +(* 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 + diff --git a/helm/ocaml/content_pres/cicNotationPres.ml b/helm/ocaml/content_pres/cicNotationPres.ml new file mode 100644 index 000000000..cc3a204a4 --- /dev/null +++ b/helm/ocaml/content_pres/cicNotationPres.ml @@ -0,0 +1,427 @@ +(* 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 *) + diff --git a/helm/ocaml/content_pres/cicNotationPres.mli b/helm/ocaml/content_pres/cicNotationPres.mli new file mode 100644 index 000000000..04411df2b --- /dev/null +++ b/helm/ocaml/content_pres/cicNotationPres.mli @@ -0,0 +1,52 @@ +(* 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 + diff --git a/helm/ocaml/content_pres/content2pres.ml b/helm/ocaml/content_pres/content2pres.ml new file mode 100644 index 000000000..4114d2b51 --- /dev/null +++ b/helm/ocaml/content_pres/content2pres.ml @@ -0,0 +1,823 @@ +(* 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 *) +(* 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))) + diff --git a/helm/ocaml/content_pres/content2pres.mli b/helm/ocaml/content_pres/content2pres.mli new file mode 100644 index 000000000..793c31a4f --- /dev/null +++ b/helm/ocaml/content_pres/content2pres.mli @@ -0,0 +1,39 @@ +(* 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 *) +(* 27/6/2003 *) +(* *) +(**************************************************************************) + +val content2pres: + ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t -> + Cic.annterm Content.cobj -> + CicNotationPres.boxml_markup + diff --git a/helm/ocaml/content_pres/content2presMatcher.ml b/helm/ocaml/content_pres/content2presMatcher.ml new file mode 100644 index 000000000..9a2f0d20b --- /dev/null +++ b/helm/ocaml/content_pres/content2presMatcher.ml @@ -0,0 +1,231 @@ +(* 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 + diff --git a/helm/ocaml/content_pres/content2presMatcher.mli b/helm/ocaml/content_pres/content2presMatcher.mli new file mode 100644 index 000000000..86b97b6d8 --- /dev/null +++ b/helm/ocaml/content_pres/content2presMatcher.mli @@ -0,0 +1,34 @@ +(* 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 + diff --git a/helm/ocaml/content_pres/mpresentation.ml b/helm/ocaml/content_pres/mpresentation.ml new file mode 100644 index 000000000..1303d1eb7 --- /dev/null +++ b/helm/ocaml/content_pres/mpresentation.ml @@ -0,0 +1,256 @@ +(* 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 *) +(* 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 "\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) + diff --git a/helm/ocaml/content_pres/mpresentation.mli b/helm/ocaml/content_pres/mpresentation.mli new file mode 100644 index 000000000..8252517a6 --- /dev/null +++ b/helm/ocaml/content_pres/mpresentation.mli @@ -0,0 +1,86 @@ +(* 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 + diff --git a/helm/ocaml/content_pres/renderingAttrs.ml b/helm/ocaml/content_pres/renderingAttrs.ml new file mode 100644 index 000000000..478ceff95 --- /dev/null +++ b/helm/ocaml/content_pres/renderingAttrs.ml @@ -0,0 +1,48 @@ +(* 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" ] + diff --git a/helm/ocaml/content_pres/renderingAttrs.mli b/helm/ocaml/content_pres/renderingAttrs.mli new file mode 100644 index 000000000..64323598b --- /dev/null +++ b/helm/ocaml/content_pres/renderingAttrs.mli @@ -0,0 +1,57 @@ +(* 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 + diff --git a/helm/ocaml/content_pres/sequent2pres.ml b/helm/ocaml/content_pres/sequent2pres.ml new file mode 100644 index 000000000..bc0dfd055 --- /dev/null +++ b/helm/ocaml/content_pres/sequent2pres.ml @@ -0,0 +1,104 @@ +(* 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 *) +(* 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))) + diff --git a/helm/ocaml/content_pres/sequent2pres.mli b/helm/ocaml/content_pres/sequent2pres.mli new file mode 100644 index 000000000..615c8e35f --- /dev/null +++ b/helm/ocaml/content_pres/sequent2pres.mli @@ -0,0 +1,39 @@ +(* 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 *) +(* 19/11/2003 *) +(* *) +(***************************************************************************) + +val sequent2pres : + ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t -> + Cic.annterm Content.conjecture -> + CicNotationPres.boxml_markup + diff --git a/helm/ocaml/content_pres/termContentPres.ml b/helm/ocaml/content_pres/termContentPres.ml new file mode 100644 index 000000000..3236fb433 --- /dev/null +++ b/helm/ocaml/content_pres/termContentPres.ml @@ -0,0 +1,647 @@ +(* 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 [] + diff --git a/helm/ocaml/content_pres/termContentPres.mli b/helm/ocaml/content_pres/termContentPres.mli new file mode 100644 index 000000000..5ff710036 --- /dev/null +++ b/helm/ocaml/content_pres/termContentPres.mli @@ -0,0 +1,52 @@ +(* 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 + diff --git a/helm/ocaml/content_pres/test_lexer.ml b/helm/ocaml/content_pres/test_lexer.ml new file mode 100644 index 000000000..569e86e44 --- /dev/null +++ b/helm/ocaml/content_pres/test_lexer.ml @@ -0,0 +1,58 @@ +(* 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 -> () + diff --git a/helm/ocaml/extlib/.depend b/helm/ocaml/extlib/.depend index cbb3fcdfe..249ee3196 100644 --- a/helm/ocaml/extlib/.depend +++ b/helm/ocaml/extlib/.depend @@ -1,2 +1,4 @@ hExtlib.cmo: hExtlib.cmi hExtlib.cmx: hExtlib.cmi +patternMatcher.cmo: patternMatcher.cmi +patternMatcher.cmx: patternMatcher.cmi diff --git a/helm/ocaml/extlib/Makefile b/helm/ocaml/extlib/Makefile index 76370ee73..9f6267a06 100644 --- a/helm/ocaml/extlib/Makefile +++ b/helm/ocaml/extlib/Makefile @@ -1,8 +1,10 @@ PACKAGE = extlib PREDICATES = -INTERFACE_FILES = \ - hExtlib.mli +INTERFACE_FILES = \ + hExtlib.mli \ + patternMatcher.mli \ + $(NULL) IMPLEMENTATION_FILES = \ $(INTERFACE_FILES:%.mli=%.ml) EXTRA_OBJECTS_TO_INSTALL = diff --git a/helm/ocaml/extlib/patternMatcher.ml b/helm/ocaml/extlib/patternMatcher.ml new file mode 100644 index 000000000..27b916bfe --- /dev/null +++ b/helm/ocaml/extlib/patternMatcher.ml @@ -0,0 +1,189 @@ +(* 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 + diff --git a/helm/ocaml/extlib/patternMatcher.mli b/helm/ocaml/extlib/patternMatcher.mli new file mode 100644 index 000000000..2201ddf7f --- /dev/null +++ b/helm/ocaml/extlib/patternMatcher.mli @@ -0,0 +1,62 @@ + +(* 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 ) + * @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 + diff --git a/helm/ocaml/grafite/.cvsignore b/helm/ocaml/grafite/.cvsignore new file mode 100644 index 000000000..8697eb7ee --- /dev/null +++ b/helm/ocaml/grafite/.cvsignore @@ -0,0 +1,5 @@ +*.cm[iaox] +*.cmxa +test_dep +test_parser +print_grammar diff --git a/helm/ocaml/grafite/.depend b/helm/ocaml/grafite/.depend new file mode 100644 index 000000000..c0590d25a --- /dev/null +++ b/helm/ocaml/grafite/.depend @@ -0,0 +1,9 @@ +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 diff --git a/helm/ocaml/grafite/Makefile b/helm/ocaml/grafite/Makefile new file mode 100644 index 000000000..f7cbc9d82 --- /dev/null +++ b/helm/ocaml/grafite/Makefile @@ -0,0 +1,31 @@ +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 diff --git a/helm/ocaml/grafite/cicNotation.ml b/helm/ocaml/grafite/cicNotation.ml new file mode 100644 index 000000000..bab8cb97b --- /dev/null +++ b/helm/ocaml/grafite/cicNotation.ml @@ -0,0 +1,90 @@ +(* 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 + diff --git a/helm/ocaml/grafite/cicNotation.mli b/helm/ocaml/grafite/cicNotation.mli new file mode 100644 index 000000000..1c6e95385 --- /dev/null +++ b/helm/ocaml/grafite/cicNotation.mli @@ -0,0 +1,44 @@ +(* 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 + diff --git a/helm/ocaml/grafite/grafiteAst.ml b/helm/ocaml/grafite/grafiteAst.ml new file mode 100644 index 000000000..2058ba37a --- /dev/null +++ b/helm/ocaml/grafite/grafiteAst.ml @@ -0,0 +1,228 @@ +(* 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 + diff --git a/helm/ocaml/grafite/grafiteAstPp.ml b/helm/ocaml/grafite/grafiteAstPp.ml new file mode 100644 index 000000000..36b54694d --- /dev/null +++ b/helm/ocaml/grafite/grafiteAstPp.ml @@ -0,0 +1,304 @@ +(* 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 ^ "\"" + diff --git a/helm/ocaml/grafite/grafiteAstPp.mli b/helm/ocaml/grafite/grafiteAstPp.mli new file mode 100644 index 000000000..79900a342 --- /dev/null +++ b/helm/ocaml/grafite/grafiteAstPp.mli @@ -0,0 +1,67 @@ +(* 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 + diff --git a/helm/ocaml/grafite/grafiteParser.ml b/helm/ocaml/grafite/grafiteParser.ml new file mode 100644 index 000000000..ea83367a8 --- /dev/null +++ b/helm/ocaml/grafite/grafiteParser.ml @@ -0,0 +1,559 @@ +(* 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>; 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> ; 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>; OPT SYMBOL "|"; + fst_constructors = LIST0 constructor SEP SYMBOL "|"; + tl = OPT [ "with"; + types = LIST1 [ + name = IDENT; SYMBOL ":"; typ = term; SYMBOL <:unicode>; + 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>; 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> (* η *); 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> ; 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> (* ≝ *); body = term -> body ] -> + GrafiteAst.Obj (loc, Ast.Theorem (flavour, name, typ, body)) + | flavour = theorem_flavour; name = IDENT; SYMBOL <:unicode> (* ≝ *); + 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 []) + diff --git a/helm/ocaml/grafite/grafiteParser.mli b/helm/ocaml/grafite/grafiteParser.mli new file mode 100644 index 000000000..256e2ef27 --- /dev/null +++ b/helm/ocaml/grafite/grafiteParser.mli @@ -0,0 +1,37 @@ +(* 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 + diff --git a/helm/ocaml/grafite/print_grammar.ml b/helm/ocaml/grafite/print_grammar.ml new file mode 100644 index 000000000..d7d6f3c96 --- /dev/null +++ b/helm/ocaml/grafite/print_grammar.ml @@ -0,0 +1,285 @@ +(* 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 "@["; + 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 "{@[ "; + let todo = visit_symbol symbol todo is_son (nesting+1) in + Format.fprintf fmt "@]} @ "; + todo + | Slist0sep (symbol,sep) -> + Format.fprintf fmt "[@[ "; + let todo = visit_symbol symbol todo is_son (nesting + 1) in + Format.fprintf fmt "{@[ "; + 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 "{@[ "; + 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 "{@[ "; + 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 "[@[ "; + 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 "@[( "; + 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 "@[%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] [] diff --git a/helm/ocaml/grafite/test_dep.ml b/helm/ocaml/grafite/test_dep.ml new file mode 100644 index 000000000..a2c7e392e --- /dev/null +++ b/helm/ocaml/grafite/test_dep.ml @@ -0,0 +1,38 @@ +(* 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 + diff --git a/helm/ocaml/grafite/test_parser.ml b/helm/ocaml/grafite/test_parser.ml new file mode 100644 index 000000000..d5edf50c9 --- /dev/null +++ b/helm/ocaml/grafite/test_parser.ml @@ -0,0 +1,161 @@ +(* 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%s%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) + diff --git a/helm/ocaml/hgdome/.cvsignore b/helm/ocaml/hgdome/.cvsignore new file mode 100644 index 000000000..8d64a5378 --- /dev/null +++ b/helm/ocaml/hgdome/.cvsignore @@ -0,0 +1,2 @@ +*.cm[iaox] +*.cmxa diff --git a/helm/ocaml/hgdome/.depend b/helm/ocaml/hgdome/.depend new file mode 100644 index 000000000..bf9c09af7 --- /dev/null +++ b/helm/ocaml/hgdome/.depend @@ -0,0 +1,4 @@ +domMisc.cmo: domMisc.cmi +domMisc.cmx: domMisc.cmi +xml2Gdome.cmo: xml2Gdome.cmi +xml2Gdome.cmx: xml2Gdome.cmi diff --git a/helm/ocaml/hgdome/Makefile b/helm/ocaml/hgdome/Makefile new file mode 100644 index 000000000..a7bb4dbb6 --- /dev/null +++ b/helm/ocaml/hgdome/Makefile @@ -0,0 +1,11 @@ +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 diff --git a/helm/ocaml/hgdome/domMisc.ml b/helm/ocaml/hgdome/domMisc.ml new file mode 100644 index 000000000..84445e19c --- /dev/null +++ b/helm/ocaml/hgdome/domMisc.ml @@ -0,0 +1,41 @@ +(* 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 *) +(* 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" + diff --git a/helm/ocaml/hgdome/domMisc.mli b/helm/ocaml/hgdome/domMisc.mli new file mode 100644 index 000000000..25d642bc5 --- /dev/null +++ b/helm/ocaml/hgdome/domMisc.mli @@ -0,0 +1,42 @@ +(* 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 *) +(* 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 *) + diff --git a/helm/ocaml/hgdome/xml2Gdome.ml b/helm/ocaml/hgdome/xml2Gdome.ml new file mode 100644 index 000000000..3d07bf21c --- /dev/null +++ b/helm/ocaml/hgdome/xml2Gdome.ml @@ -0,0 +1,133 @@ +(* 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 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 +;; diff --git a/helm/ocaml/hgdome/xml2Gdome.mli b/helm/ocaml/hgdome/xml2Gdome.mli new file mode 100644 index 000000000..45d0e9532 --- /dev/null +++ b/helm/ocaml/hgdome/xml2Gdome.mli @@ -0,0 +1,27 @@ +(* 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 diff --git a/helm/ocaml/xml/xml.ml b/helm/ocaml/xml/xml.ml index 42ce7ba57..809e11d3f 100644 --- a/helm/ocaml/xml/xml.ml +++ b/helm/ocaml/xml/xml.ml @@ -160,3 +160,16 @@ let add_xml_declaration stream = ] 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 + diff --git a/helm/ocaml/xml/xml.mli b/helm/ocaml/xml/xml.mli index 43547eaa0..4feca7503 100644 --- a/helm/ocaml/xml/xml.mli +++ b/helm/ocaml/xml/xml.mli @@ -71,3 +71,5 @@ val pp_to_string : token Stream.t -> string val add_xml_declaration: token Stream.t -> token Stream.t +val strip_xml_headings: string -> string +