(* helper functions *********************************************************)
+let rec list_fold_right_cps g map l a =
+ match l with
+ | [] -> g a
+ | hd :: tl ->
+ let h a = map g hd a in
+ list_fold_right_cps h map tl a
+
+let rec list_fold_left_cps g map a = function
+ | [] -> g a
+ | hd :: tl ->
+ let h a = list_fold_left_cps g map a tl in
+ map h a hd
+
let rec list_map_cps g map = function
| [] -> g []
| hd :: tl ->
let fst3 (x, _, _) = x
let refine c t =
- try let t, _, _, _ = Rf.type_of_aux' [] c t Un.oblivion_ugraph in t
- with e ->
- Printf.eprintf "REFINE EROR: %s\n" (Printexc.to_string e);
+ let error e =
Printf.eprintf "Ref: context: %s\n" (Pp.ppcontext c);
Printf.eprintf "Ref: term : %s\n" (Pp.ppterm t);
raise e
+ in
+ try let t, _, _, _ = Rf.type_of_aux' [] c t Un.default_ugraph in t with
+ | Rf.RefineFailure s as e ->
+ Printf.eprintf "REFINE FAILURE: %s\n" (Lazy.force s);
+ error e
+ | e ->
+ Printf.eprintf "REFINE ERROR: %s\n" (Printexc.to_string e);
+ error e
-let get_type c t =
- try let ty, _ = TC.type_of_aux' [] c t Un.oblivion_ugraph in ty
- with e ->
- Printf.eprintf "TC: context: %s\n" (Pp.ppcontext c);
- Printf.eprintf "TC: term : %s\n" (Pp.ppterm t);
- raise e
+let get_type msg c t =
+ let log s =
+ prerr_endline ("TC: " ^ s);
+ prerr_endline ("TC: context: " ^ Pp.ppcontext c);
+ prerr_string "TC: term : "; Ut.pp_term prerr_string [] c t;
+ prerr_newline (); prerr_endline ("TC: location: " ^ msg)
+ in
+ try let ty, _ = TC.type_of_aux' [] c t Un.default_ugraph in ty with
+ | TC.TypeCheckerFailure s as e ->
+ log ("failure: " ^ Lazy.force s); raise e
+ | TC.AssertFailure s as e ->
+ log ("assert : " ^ Lazy.force s); raise e
let get_tail c t =
match PEH.split_with_whd (c, t) with
| (_, hd) :: _, _ -> hd
| _ -> assert false
-let is_proof c t =
- match get_tail c (get_type c (get_type c t)) with
+let is_prop c t =
+ match get_tail c (get_type "is_prop" c t) with
| C.Sort C.Prop -> true
| C.Sort _ -> false
| _ -> assert false
+let is_proof c t =
+ is_prop c (get_type "is_prop" c t)
+
let is_sort = function
| C.Sort _ -> true
| _ -> false
let is_atomic t = not (is_not_atomic t)
let get_ind_type uri tyno =
- match E.get_obj Un.oblivion_ugraph uri with
+ match E.get_obj Un.default_ugraph uri with
| C.InductiveDefinition (tys, _, lpsno, _), _ -> lpsno, List.nth tys tyno
| _ -> assert false
+let get_ind_names uri tno =
+try
+ let ts = match E.get_obj Un.default_ugraph uri with
+ | C.InductiveDefinition (ts, _, _, _), _ -> ts
+ | _ -> assert false
+ in
+ match List.nth ts tno with
+ | (_, _, _, cs) -> List.map fst cs
+with Invalid_argument _ -> failwith "get_ind_names"
+
let get_default_eliminator context uri tyno ty =
let _, (name, _, _, _) = get_ind_type uri tyno in
- let ext = match get_tail context (get_type context ty) with
+ let ext = match get_tail context (get_type "get_def_elim" context ty) with
| C.Sort C.Prop -> "_ind"
| C.Sort C.Set -> "_rec"
| C.Sort (C.CProp _) -> "_rect"
C.Const (uri, [])
let get_ind_parameters c t =
- let ty = get_type c t in
+ let ty = get_type "get_ind_pars 1" c t in
let ps = match get_tail c ty with
| C.MutInd _ -> []
| C.Appl (C.MutInd _ :: args) -> args
| _ -> assert false
in
- let disp = match get_tail c (get_type c ty) with
+ let disp = match get_tail c (get_type "get_ind_pars 2" c ty) with
| C.Sort C.Prop -> 0
| C.Sort _ -> 1
| _ -> assert false
let get_ind_type tys tyno =
let s, _, _, cs = List.nth tys tyno in s, cs
in
- match (fst (E.get_obj Un.oblivion_ugraph uri)), tyno, cno with
+ match (fst (E.get_obj Un.default_ugraph uri)), tyno, cno with
| C.Variable (s, _, _, _, _), _, _ -> s
| C.Constant (s, _, _, _, _), _, _ -> s
| C.InductiveDefinition (tys, _, _, _), Some i, None ->