+open Printf
+
+let pp_indtypes indTypes =
+ List.iter
+ (fun (name, _, typ, constructors) ->
+ printf "%s: %s\n" name (CicPp.ppterm typ);
+ List.iter
+ (fun (name, term) -> printf "\t%s: %s\n" name (CicPp.ppterm term))
+ constructors)
+ indTypes;
+ flush stdout
+
+let inddef_of_ast params indTypes (disambiguator:MatitaTypes.disambiguator) =
+ let add_pi binders t =
+ List.fold_right
+ (fun (name, ast) acc ->
+ CicAst.Binder (`Forall, (Cic.Name name, Some ast), acc))
+ binders t
+ in
+ let ind_binders =
+ List.map (fun (name, _, typ, _) -> (name, add_pi params typ)) indTypes
+ in
+ let binders = ind_binders @ params in
+ let asts = ref [] in
+ let add_ast ast = asts := ast :: !asts in
+ let paramsno = List.length params in
+ let indbindersno = List.length ind_binders in
+ List.iter
+ (fun (name, _, typ, constructors) ->
+ add_ast (add_pi params typ);
+ List.iter (fun (_, ast) -> add_ast (add_pi binders ast)) constructors)
+ indTypes;
+ let (_, metasenv, terms, ugraph) =
+ disambiguator#disambiguateTermAsts ~metasenv:[] !asts
+ in
+ let terms = ref (List.rev terms) in
+ let get_term () =
+ match !terms with [] -> assert false | hd :: tl -> terms := tl; hd
+ in
+ let uri =
+ match indTypes with
+ | (name, _, _, _) :: _ -> qualify name ^ ".ind"
+ | _ -> assert false
+ in
+ let mutinds =
+ let counter = ref 0 in
+ List.map
+ (fun _ ->
+ incr counter;
+ CicUtil.term_of_uri (sprintf "%s#xpointer(1/%d)" uri !counter))
+ indTypes
+ in
+ let subst_mutinds = List.fold_right CicSubstitution.subst mutinds in
+ let cicIndTypes =
+ List.fold_left
+ (fun acc (name, inductive, typ, constructors) ->
+ let cicTyp = get_term () in
+ let cicConstructors =
+ List.fold_left
+ (fun acc (name, _) ->
+ let typ =
+ subst_mutinds (CicUtil.strip_prods indbindersno (get_term ()))
+ in
+ (name, typ) :: acc)
+ [] constructors
+ in
+ (name, inductive, cicTyp, List.rev cicConstructors) :: acc)
+ [] indTypes
+ in
+ let cicIndTypes = List.rev cicIndTypes in
+(*
+ prerr_endline uri;
+ pp_indtypes cicIndTypes;
+*)
+ (UriManager.uri_of_string uri, (cicIndTypes, [], paramsno))
+
+ (* TODO Zack a lot more to be done here:
+ * - save object to disk in xml format
+ * - register uri to the getter
+ * - save universe file *)
+let add_constant_to_world ~dbd ~uri ?body ~ty ~ugraph () =
+ let name = UriManager.name_of_uri uri in
+ let obj = Cic.Constant (name, body, ty, []) in
+ let ugraph = CicUnivUtils.clean_and_fill uri obj ugraph in
+ CicEnvironment.add_type_checked_term uri (obj, ugraph);
+ MetadataDb.index_constant ~dbd
+ ~owner:(Helm_registry.get "matita.owner") ~uri ~body ~ty
+
+ (** Implements phrases that should be accepted only in Command state *)