+ aux ctxt.stack
+
+(** {2 Push parser callbacks}
+ * each callback needs to be instantiated to a parsing context *)
+
+let start_element ctxt tag attrs =
+(* debug_print (sprintf "<%s%s>" tag (match attrs with | [] -> "" | _ -> " " ^ String.concat " " (List.map (fun (a,v) -> sprintf "%s=\"%s\"" a v) attrs)));*)
+ push ctxt (Tag (tag, attrs))
+
+let end_element ctxt tag =
+(* debug_print (sprintf "</%s>" tag);*)
+(* debug_print (string_of_stack ctxt);*)
+ let attribute_error () = attribute_error ctxt tag in
+ let parse_error = parse_error ctxt in
+ let sort_of_string = sort_of_string ctxt in
+ match tag with
+ | "REL" ->
+ push ctxt (Cic_term
+ (match pop_tag_attrs ctxt with
+ | ["binder", binder; "id", id; "idref", idref; "sort", _;
+ "value", value] ->
+ Cic.ARel (id, idref, int_of_string value, binder)
+ | _ -> attribute_error ()))
+ | "VAR" ->
+ push ctxt (Cic_term
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "sort", _; "uri", uri] ->
+ Cic.AVar (id, uri_of_string uri, [])
+ | _ -> attribute_error ()))
+ | "CONST" ->
+ push ctxt (Cic_term
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "sort", _; "uri", uri] ->
+ Cic.AConst (id, uri_of_string uri, [])
+ | _ -> attribute_error ()))
+ | "SORT" ->
+ push ctxt (Cic_term
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "value", sort] -> Cic.ASort (id, sort_of_string sort)
+ | _ -> attribute_error ()))
+ | "APPLY" ->
+ let args = pop_cics ctxt in
+ push ctxt (Cic_term
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "sort", _] -> Cic.AAppl (id, args)
+ | _ -> attribute_error ()))
+ | "decl" ->
+ let source = pop_cic ctxt in
+ push ctxt
+ (match pop_tag_attrs ctxt with
+ | ["binder", binder; "id", id; "type", _] ->
+ Decl (id, Cic.Name binder, source)
+ | ["id", id; "type", _] -> Decl (id, Cic.Anonymous, source)
+ | _ -> attribute_error ())
+ | "def" -> (* same as "decl" above *)
+ let source = pop_cic ctxt in
+ push ctxt
+ (match pop_tag_attrs ctxt with
+ | ["binder", binder; "id", id; "sort", _] ->
+ Def (id, Cic.Name binder, source)
+ | ["id", id; "sort", _] -> Def (id, Cic.Anonymous, source)
+ | _ -> attribute_error ())
+ | "arity" (* transparent elements (i.e. which contain a CIC) *)
+ | "body"
+ | "inductiveTerm"
+ | "pattern"
+ | "patternsType"
+ | "target"
+ | "term"
+ | "type" ->
+ let term = pop_cic ctxt in
+ pop ctxt; (* pops start tag matching current end tag (e.g. <arity>) *)
+ push ctxt (Cic_term term)
+ | "substitution" -> (* optional transparent elements (i.e. which _may_
+ * contain a CIC) *)
+ set_top ctxt (* replace <substitution> *)
+ (match ctxt.stack with
+ | Cic_term term :: tl ->
+ ctxt.stack <- tl;
+ (Meta_subst (Some term))
+ | _ -> Meta_subst None)
+ | "PROD" ->
+ let target = pop_cic ctxt in
+ let rec add_decl target = function
+ | Decl (id, binder, source) :: tl ->
+ add_decl (Cic.AProd (id, binder, source, target)) tl
+ | tl ->
+ ctxt.stack <- tl;
+ target
+ in
+ let term = add_decl target ctxt.stack in
+ (match pop_tag_attrs ctxt with
+ | ["type", _] -> ()
+ | _ -> attribute_error ());
+ push ctxt (Cic_term term)
+ | "LAMBDA" ->
+ let target = pop_cic ctxt in
+ let rec add_decl target = function
+ | Decl (id, binder, source) :: tl ->
+ add_decl (Cic.ALambda (id, binder, source, target)) tl
+ | tl ->
+ ctxt.stack <- tl;
+ target
+ in
+ let term = add_decl target ctxt.stack in
+ (match pop_tag_attrs ctxt with
+ | ["sort", _] -> ()
+ | _ -> attribute_error ());
+ push ctxt (Cic_term term)
+ | "LETIN" ->
+ let target = pop_cic ctxt in
+ let rec add_def target = function
+ | Def (id, binder, source) :: tl ->
+ add_def (Cic.ALetIn (id, binder, source, target)) tl
+ | tl ->
+ ctxt.stack <- tl;
+ target
+ in
+ let term = add_def target ctxt.stack in
+ (match pop_tag_attrs ctxt with
+ | ["sort", _] -> ()
+ | _ -> attribute_error ());
+ push ctxt (Cic_term term)
+ | "CAST" ->
+ let typ = pop_cic ctxt in
+ let term = pop_cic ctxt in
+ push ctxt (Cic_term
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "sort", _] -> Cic.ACast (id, term, typ)
+ | _ -> attribute_error ()));
+ | "IMPLICIT" ->
+ push ctxt (Cic_term
+ (match pop_tag_attrs ctxt with
+ | ["id", id] -> Cic.AImplicit (id, None)
+ | ["annotation", annotation; "id", id] ->
+ let implicit_annotation =
+ match annotation with
+ | "closed" -> `Closed
+ | "hole" -> `Hole
+ | "type" -> `Type
+ | _ -> parse_error "invalid value for \"annotation\" attribute"
+ in
+ Cic.AImplicit (id, Some implicit_annotation)
+ | _ -> attribute_error ()))
+ | "META" ->
+ let meta_substs = pop_meta_substs ctxt in
+ push ctxt (Cic_term
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "no", no; "sort", _] ->
+ Cic.AMeta (id, int_of_string no, meta_substs)
+ | _ -> attribute_error ()));
+ | "MUTIND" ->
+ push ctxt (Cic_term
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "noType", noType; "uri", uri] ->
+ Cic.AMutInd (id, uri_of_string uri, int_of_string noType, [])
+ | _ -> attribute_error ()));
+ | "MUTCONSTRUCT" ->
+ push ctxt (Cic_term
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "noConstr", noConstr; "noType", noType; "sort", _;
+ "uri", uri] ->
+ Cic.AMutConstruct (id, uri_of_string uri, int_of_string noType,
+ int_of_string noConstr, [])
+ | _ -> attribute_error ()));
+ | "FixFunction" ->
+ let body = pop_cic ctxt in
+ let typ = pop_cic ctxt in
+ push ctxt
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "name", name; "recIndex", recIndex] ->
+ Fix_fun (id, name, int_of_string recIndex, typ, body)
+ | _ -> attribute_error ())
+ | "CofixFunction" ->
+ let body = pop_cic ctxt in
+ let typ = pop_cic ctxt in
+ push ctxt
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "name", name] ->
+ Cofix_fun (id, name, typ, body)
+ | _ -> attribute_error ())
+ | "FIX" ->
+ let fix_funs = pop_fix_funs ctxt in
+ push ctxt (Cic_term
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "noFun", noFun; "sort", _] ->
+ Cic.AFix (id, int_of_string noFun, fix_funs)
+ | _ -> attribute_error ()))
+ | "COFIX" ->
+ let cofix_funs = pop_cofix_funs ctxt in
+ push ctxt (Cic_term
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "noFun", noFun; "sort", _] ->
+ Cic.ACoFix (id, int_of_string noFun, cofix_funs)
+ | _ -> attribute_error ()))
+ | "MUTCASE" ->
+ (match pop_cics ctxt with
+ | patternsType :: inductiveTerm :: patterns ->
+ push ctxt (Cic_term
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "noType", noType; "sort", _; "uriType", uriType] ->
+ Cic.AMutCase (id, uri_of_string uriType, int_of_string noType,
+ patternsType, inductiveTerm, patterns)
+ | _ -> attribute_error ()))
+ | _ -> parse_error "invalid \"MUTCASE\" content")
+ | "Constructor" ->
+ let typ = pop_cic ctxt in
+ push ctxt
+ (match pop_tag_attrs ctxt with
+ | ["name", name] -> Constructor (name, typ)
+ | _ -> attribute_error ())
+ | "InductiveType" ->
+ let constructors = pop_constructors ctxt in
+ let arity = pop_cic ctxt in
+ push ctxt
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "inductive", inductive; "name", name] ->
+ Inductive_type (id, name, bool_of_string inductive, arity,
+ constructors)
+ | _ -> attribute_error ())
+ | "InductiveDefinition" ->
+ let inductive_types = pop_inductive_types ctxt in
+ let obj_attributes = pop_obj_attributes ctxt in
+ push ctxt (Cic_obj
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "noParams", noParams; "params", params] ->
+ Cic.AInductiveDefinition (id, inductive_types,
+ uri_list_of_string params, int_of_string noParams, obj_attributes)
+ | _ -> attribute_error ()))
+ | "ConstantType" ->
+ let typ = pop_cic ctxt in
+ let obj_attributes = pop_obj_attributes ctxt in
+ push ctxt
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "name", name; "params", params] ->
+ Cic_constant_type (id, name, uri_list_of_string params, typ,
+ obj_attributes)
+ | _ -> attribute_error ())
+ | "ConstantBody" ->
+ let body = pop_cic ctxt in
+ let obj_attributes = pop_obj_attributes ctxt in
+ push ctxt
+ (match pop_tag_attrs ctxt with
+ | ["for", for_; "id", id; "params", params] ->
+ Cic_constant_body (id, for_, uri_list_of_string params, body,
+ obj_attributes)
+ | _ -> attribute_error ())
+ | "Variable" ->
+ let typ = pop_cic ctxt in
+ let body =
+ match pop_cics ctxt with
+ | [] -> None
+ | [t] -> Some t
+ | _ -> parse_error "wrong content for \"Variable\""
+ in
+ let obj_attributes = pop_obj_attributes ctxt in
+ push ctxt (Cic_obj
+ (match pop_tag_attrs ctxt with
+ | ["id", id; "name", name; "params", params] ->
+ Cic.AVariable (id, name, body, typ, uri_list_of_string params,
+ obj_attributes)
+ | _ -> attribute_error ()))
+ | "arg" ->
+ let term = pop_cic ctxt in
+ push ctxt
+ (match pop_tag_attrs ctxt with
+ | ["relUri", relUri] -> Arg (relUri, term)
+ | _ -> attribute_error ())
+ | "instantiate" ->
+ (* explicit named substitution handling: when the end tag of an element
+ * subject of exlicit named subst (MUTIND, MUTCONSTRUCT, CONST, VAR) it
+ * is stored on the stack with no substitutions (i.e. []). When the end
+ * tag of an "instantiate" element is found we patch the term currently
+ * on the stack with the substitution built from "instantiate" children
+ *)
+ (* XXX inefficiency here: first travels the <arg> elements in order to
+ * find the baseUri, then in order to build the explicit named subst *)
+ let base_uri = find_base_uri ctxt in
+ let subst = pop_subst ctxt base_uri in
+ let term = pop_cic ctxt in
+ (* comment from CicParser3.ml:
+ * CSC: the "id" optional attribute should be parsed and reflected in
+ * Cic.annterm and id = string_of_xml_attr (n#attribute "id") *)
+ (* replace <instantiate> *)
+ set_top ctxt (Cic_term (patch_subst ctxt subst term))
+ | "attributes" ->
+ let rec aux acc = function (* retrieve object attributes *)
+ | Obj_class c :: tl -> aux (`Class c :: acc) tl
+ | Obj_generated :: tl -> aux (`Generated :: acc) tl
+ | tl -> acc, tl
+ in
+ let obj_attrs, new_stack = aux [] ctxt.stack in
+ ctxt.stack <- new_stack;
+ set_top ctxt (Cic_attributes obj_attrs)
+ | "generated" -> set_top ctxt Obj_generated
+ | "field" ->
+ push ctxt
+ (match pop_tag_attrs ctxt with
+ | ["name", name] -> Obj_field name
+ | _ -> attribute_error ())
+ | "class" ->
+ let class_modifiers = pop_class_modifiers ctxt in
+ push ctxt
+ (match pop_tag_attrs ctxt with
+ | ["value", "coercion"] -> Obj_class `Coercion
+ | ["value", "elim"] ->
+ (match class_modifiers with
+ | [Cic_term (Cic.ASort (_, sort))] -> Obj_class (`Elim sort)
+ | _ ->
+ parse_error
+ "unexpected extra content for \"elim\" object class")
+ | ["value", "record"] ->
+ let fields =
+ List.map
+ (function
+ | Obj_field name -> name
+ | _ ->
+ parse_error
+ "unexpected extra content for \"record\" object class")
+ class_modifiers
+ in
+ Obj_class (`Record fields)
+ | ["value", "projection"] -> Obj_class `Projection
+ | _ -> attribute_error ())
+ | tag ->
+ match find_helm_exception ctxt with
+ | Some (exn, arg) -> raise (Getter_failure (exn, arg))
+ | None -> parse_error (sprintf "unknown element \"%s\"" tag)
+
+(** {2 Parser internals} *)
+
+let parse uri filename =
+ let ctxt = new_parser_context uri in
+ ctxt.filename <- filename;
+ let module P = XmlPushParser in
+ let callbacks = {
+ P.default_callbacks with
+ P.start_element = Some (start_element ctxt);
+ P.end_element = Some (end_element ctxt);
+ } in
+ let xml_parser = P.create_parser callbacks in
+ ctxt.xml_parser <- Some xml_parser;
+ try
+ (try
+ P.parse xml_parser (`Gzip_file filename);
+ with exn ->
+ ctxt.xml_parser <- None;
+ (* ZACK: the above "<- None" is vital for garbage collection. Without it
+ * we keep in memory a circular structure parser -> callbacks -> ctxt ->
+ * parser. I don't know if the ocaml garbage collector is supposed to
+ * collect such structures, but for sure the expat bindings will (orribly)
+ * leak when used in conjunction with such structures *)
+ raise exn);
+ ctxt.xml_parser <- None; (* ZACK: same comment as above *)
+(* debug_print (string_of_stack stack);*)
+ (* assert (List.length ctxt.stack = 1) *)
+ List.hd ctxt.stack
+ with
+ | Failure "int_of_string" -> parse_error ctxt "integer number expected"
+ | Invalid_argument "bool_of_string" -> parse_error ctxt "boolean expected"
+ | P.Parse_error msg -> parse_error ctxt ("parse error: " ^ msg)
+ | Parser_failure _
+ | Getter_failure _ as exn ->
+ raise exn
+ | exn ->
+ raise (Parser_failure ("uncaught exception: " ^ Printexc.to_string exn))
+
+(** {2 API implementation} *)