X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fcic_unification%2FcicMetaSubst.ml;h=9695d714b7658940392fc4401af71d3701d7298f;hb=5325734bc2e4927ed7ec146e35a6f0f2b49f50c1;hp=30069cdfec88d12f6549922d14d0c1a6561adf90;hpb=a886fdf011c202071e76c5716d59a335ec5d321d;p=helm.git diff --git a/helm/ocaml/cic_unification/cicMetaSubst.ml b/helm/ocaml/cic_unification/cicMetaSubst.ml index 30069cdfe..9695d714b 100644 --- a/helm/ocaml/cic_unification/cicMetaSubst.ml +++ b/helm/ocaml/cic_unification/cicMetaSubst.ml @@ -1,18 +1,278 @@ +(* 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://cs.unibo.it/helm/. + *) open Printf -exception AssertFailure of string exception MetaSubstFailure of string +exception Uncertain of string +exception AssertFailure of string let debug_print = prerr_endline type substitution = (int * Cic.term) list +(*** Functions to apply a substitution ***) + +let apply_subst_gen ~appl_fun subst term = + let rec um_aux = + let module C = Cic in + let module S = CicSubstitution in + function + C.Rel _ as t -> t + | C.Var (uri,exp_named_subst) -> + let exp_named_subst' = + List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst + in + C.Var (uri, exp_named_subst') + | C.Meta (i, l) -> + (try + let t = List.assoc i subst in + um_aux (S.lift_meta l t) + with Not_found -> (* not constrained variable, i.e. free in subst*) + let l' = + List.map (function None -> None | Some t -> Some (um_aux t)) l + in + C.Meta (i,l')) + | C.Sort _ as t -> t + | C.Implicit _ -> assert false + | C.Cast (te,ty) -> C.Cast (um_aux te, um_aux ty) + | C.Prod (n,s,t) -> C.Prod (n, um_aux s, um_aux t) + | C.Lambda (n,s,t) -> C.Lambda (n, um_aux s, um_aux t) + | C.LetIn (n,s,t) -> C.LetIn (n, um_aux s, um_aux t) + | C.Appl (hd :: tl) -> appl_fun um_aux hd tl + | C.Appl _ -> assert false + | C.Const (uri,exp_named_subst) -> + let exp_named_subst' = + List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst + in + C.Const (uri, exp_named_subst') + | C.MutInd (uri,typeno,exp_named_subst) -> + let exp_named_subst' = + List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst + in + C.MutInd (uri,typeno,exp_named_subst') + | C.MutConstruct (uri,typeno,consno,exp_named_subst) -> + let exp_named_subst' = + List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst + in + C.MutConstruct (uri,typeno,consno,exp_named_subst') + | C.MutCase (sp,i,outty,t,pl) -> + let pl' = List.map um_aux pl in + C.MutCase (sp, i, um_aux outty, um_aux t, pl') + | C.Fix (i, fl) -> + let fl' = + List.map (fun (name, i, ty, bo) -> (name, i, um_aux ty, um_aux bo)) fl + in + C.Fix (i, fl') + | C.CoFix (i, fl) -> + let fl' = + List.map (fun (name, ty, bo) -> (name, um_aux ty, um_aux bo)) fl + in + C.CoFix (i, fl') + in + um_aux term +;; + +let apply_subst = + let appl_fun um_aux he tl = + let tl' = List.map um_aux tl in + begin + match um_aux he with + Cic.Appl l -> Cic.Appl (l@tl') + | he' -> Cic.Appl (he'::tl') + end + in + apply_subst_gen ~appl_fun +;; + +(* apply_subst_reducing subst (Some (mtr,reductions_no)) t *) +(* performs as (apply_subst subst t) until it finds an application of *) +(* (META [meta_to_reduce]) that, once unwinding is performed, creates *) +(* a new beta-redex; in this case up to [reductions_no] consecutive *) +(* beta-reductions are performed. *) +(* Hint: this function is usually called when [reductions_no] *) +(* eta-expansions have been performed and the head of the new *) +(* application has been unified with (META [meta_to_reduce]): *) +(* during the unwinding the eta-expansions are undone. *) + +let apply_subst_reducing meta_to_reduce = + let appl_fun um_aux he tl = + let tl' = List.map um_aux tl in + let t' = + match um_aux he with + Cic.Appl l -> Cic.Appl (l@tl') + | he' -> Cic.Appl (he'::tl') + in + begin + match meta_to_reduce, he with + Some (mtr,reductions_no), Cic.Meta (m,_) when m = mtr -> + let rec beta_reduce = + function + (n,(Cic.Appl (Cic.Lambda (_,_,t)::he'::tl'))) when n > 0 -> + let he'' = CicSubstitution.subst he' t in + if tl' = [] then + he'' + else + beta_reduce (n-1,Cic.Appl(he''::tl')) + | (_,t) -> t + in + beta_reduce (reductions_no,t') + | _,_ -> t' + end + in + apply_subst_gen ~appl_fun + +let rec apply_subst_context subst context = + List.fold_right + (fun item context -> + match item with + | Some (n, Cic.Decl t) -> + let t' = apply_subst subst t in + Some (n, Cic.Decl t') :: context + | Some (n, Cic.Def (t, ty)) -> + let ty' = + match ty with + | None -> None + | Some ty -> Some (apply_subst subst ty) + in + let t' = apply_subst subst t in + Some (n, Cic.Def (t', ty')) :: context + | None -> None :: context) + context [] + +let apply_subst_metasenv subst metasenv = + List.map + (fun (n, context, ty) -> + (n, apply_subst_context subst context, apply_subst subst ty)) + (List.filter + (fun (i, _, _) -> not (List.exists (fun (j, _) -> (j = i)) subst)) + metasenv) + +(***** Pretty printing functions ******) + let ppsubst subst = String.concat "\n" (List.map (fun (idx, term) -> Printf.sprintf "?%d := %s" idx (CicPp.ppterm term)) subst) +;; + +let ppterm subst term = CicPp.ppterm (apply_subst subst term) + +let ppterm_in_context subst term name_context = + CicPp.pp (apply_subst subst term) name_context + +let ppcontext' ?(sep = "\n") subst context = + let separate s = if s = "" then "" else s ^ sep in + List.fold_right + (fun context_entry (i,name_context) -> + match context_entry with + Some (n,Cic.Decl t) -> + sprintf "%s%s : %s" (separate i) (CicPp.ppname n) + (ppterm_in_context subst t name_context), (Some n)::name_context + | Some (n,Cic.Def (bo,ty)) -> + sprintf "%s%s : %s := %s" (separate i) (CicPp.ppname n) + (match ty with + None -> "_" + | Some ty -> ppterm_in_context subst ty name_context) + (ppterm_in_context subst bo name_context), (Some n)::name_context + | None -> + sprintf "%s_ :? _" (separate i), None::name_context + ) context ("",[]) + +let ppcontext ?sep subst context = fst (ppcontext' ?sep subst context) + +let ppmetasenv ?(sep = "\n") metasenv subst = + String.concat sep + (List.map + (fun (i, c, t) -> + let context,name_context = ppcontext' ~sep:"; " subst c in + sprintf "%s |- ?%d: %s" context i + (ppterm_in_context subst t name_context)) + (List.filter + (fun (i, _, _) -> not (List.exists (fun (j, _) -> (j = i)) subst)) + metasenv)) + +(* From now on we recreate a kernel abstraction where substitutions are part of + * the calculus *) + +let lift subst n term = + let term = apply_subst subst term in + try + CicSubstitution.lift n term + with e -> + raise (MetaSubstFailure ("Lift failure: " ^ Printexc.to_string e)) + +let subst subst t1 t2 = + let t1 = apply_subst subst t1 in + let t2 = apply_subst subst t2 in + try + CicSubstitution.subst t1 t2 + with e -> + raise (MetaSubstFailure ("Subst failure: " ^ Printexc.to_string e)) + +let whd subst context term = + let term = apply_subst subst term in + let context = apply_subst_context subst context in + try + CicReduction.whd context term + with e -> + raise (MetaSubstFailure ("Weak head reduction failure: " ^ + Printexc.to_string e)) + +let are_convertible subst context t1 t2 = + let context = apply_subst_context subst context in + let t1 = apply_subst subst t1 in + let t2 = apply_subst subst t2 in + CicReduction.are_convertible context t1 t2 + +let tempi_type_of_aux_subst = ref 0.0;; +let tempi_type_of_aux = ref 0.0;; + +let type_of_aux' metasenv subst context term = +let time1 = Unix.gettimeofday () in + let term = apply_subst subst term in + let context = apply_subst_context subst context in + let metasenv = + List.map + (fun (i, c, t) -> (i, apply_subst_context subst c, apply_subst subst t)) + (List.filter + (fun (i, _, _) -> not (List.exists (fun (j, _) -> (j = i)) subst)) + metasenv) + in +let time2 = Unix.gettimeofday () in +let res = + try + CicTypeChecker.type_of_aux' metasenv context term + with CicTypeChecker.TypeCheckerFailure msg -> + raise (MetaSubstFailure ("Type checker failure: " ^ msg)) +in +let time3 = Unix.gettimeofday () in + tempi_type_of_aux_subst := !tempi_type_of_aux_subst +. time3 -. time1 ; + tempi_type_of_aux := !tempi_type_of_aux +. time2 -. time1 ; + res (**** DELIFT ****) (* the delift function takes in input a metavariable index, an ordered list of @@ -46,10 +306,10 @@ let rec force_does_not_occur subst to_be_restricted t = let module C = Cic in let more_to_be_restricted = ref [] in let rec aux k = function - C.Rel r when List.mem (r+k) to_be_restricted -> raise Occur + C.Rel r when List.mem (r - k) to_be_restricted -> raise Occur | C.Rel _ | C.Sort _ as t -> t - | C.Implicit -> assert false + | C.Implicit _ -> assert false | C.Meta (n, l) -> (* we do not retrieve the term associated to ?n in subst since *) (* in this way we can restrict if something goes wrong *) @@ -121,10 +381,13 @@ let rec restrict subst to_be_restricted metasenv = String.concat ", " (List.map (fun i -> - match List.nth context i with - | None -> assert false - | Some (n, _) -> CicPp.ppname n) - indexes) + try + match List.nth context i with + | None -> assert false + | Some (n, _) -> CicPp.ppname n + with + Failure _ -> assert false + ) indexes) in let force_does_not_occur_in_context to_be_restricted = function | None -> [], None @@ -132,7 +395,7 @@ let rec restrict subst to_be_restricted metasenv = let (more_to_be_restricted, t') = force_does_not_occur subst to_be_restricted t in - more_to_be_restricted, Some (name, Cic.Decl t) + more_to_be_restricted, Some (name, Cic.Decl t') | Some (name, Cic.Def (bo, ty)) -> let (more_to_be_restricted, bo') = force_does_not_occur subst to_be_restricted bo @@ -152,27 +415,30 @@ let rec restrict subst to_be_restricted metasenv = let rec erase i to_be_restricted n = function | [] -> [], to_be_restricted, [] | hd::tl -> - let restrict_me = List.mem i to_be_restricted in + let more_to_be_restricted,restricted,tl' = + erase (i+1) to_be_restricted n tl + in + let restrict_me = List.mem i restricted in if restrict_me then - let more_to_be_restricted, restricted, new_tl = - erase (i+1) (i :: to_be_restricted) n tl - in - more_to_be_restricted, restricted, None :: new_tl + more_to_be_restricted, restricted, None:: tl' else (try - let more_to_be_restricted, hd' = - force_does_not_occur_in_context to_be_restricted hd - in - let more_to_be_restricted', restricted, tl' = - erase (i+1) to_be_restricted n tl + let more_to_be_restricted', hd' = + let delifted_restricted = + let rec aux = + function + [] -> [] + | j::tl when j > i -> (j - i)::aux tl + | _::tl -> aux tl + in + aux restricted + in + force_does_not_occur_in_context delifted_restricted hd in - more_to_be_restricted @ more_to_be_restricted', - restricted, hd' :: tl' + more_to_be_restricted @ more_to_be_restricted', + restricted, hd' :: tl' with Occur -> - let more_to_be_restricted, restricted, tl' = - erase (i+1) (i :: to_be_restricted) n tl - in - more_to_be_restricted, restricted, None :: tl') + more_to_be_restricted, (i :: restricted), None :: tl') in let (more_to_be_restricted, metasenv, subst) = List.fold_right @@ -181,6 +447,10 @@ let rec restrict subst to_be_restricted metasenv = List.map snd (List.filter (fun (m, _) -> m = n) to_be_restricted) in let (more_to_be_restricted, restricted, context') = + (* just an optimization *) + if to_be_restricted = [] then + [],[],context + else erase 1 to_be_restricted n context in try @@ -204,7 +474,7 @@ let rec restrict subst to_be_restricted metasenv = raise (MetaSubstFailure (sprintf "Cannot restrict the context of the metavariable ?%d over the hypotheses %s since ?%d is already instantiated with %s and at least one of the hypotheses occurs in the substituted term" n (names_of_context_indexes context to_be_restricted) n - (CicPp.ppterm s))) + (ppterm subst s))) with Not_found -> (more @ more_to_be_restricted @ more_to_be_restricted', metasenv', subst)) with Occur -> raise (MetaSubstFailure (sprintf @@ -220,6 +490,14 @@ let rec restrict subst to_be_restricted metasenv = (*CSC: maybe we should rename delift in abstract, as I did in my dissertation *) let delift n subst context metasenv l t = let module S = CicSubstitution in + let l = + let (_, canonical_context, _) = CicUtil.lookup_meta n metasenv in + List.map2 (fun ct lt -> + match (ct, lt) with + | None, _ -> None + | Some _, _ -> lt) + canonical_context l + in let to_be_restricted = ref [] in let rec deliftaux k = let module C = Cic in @@ -230,24 +508,19 @@ let delift n subst context metasenv l t = (*CSC: deliftato la regola per il LetIn *) (*CSC: FALSO! La regola per il LetIn non lo fa *) else - (match List.nth context (m-k-1) with - Some (_,C.Def (t,_)) -> - (*CSC: Hmmm. This bit of reduction is not in the spirit of *) - (*CSC: first order unification. Does it help or does it harm? *) - deliftaux k (S.lift m t) - | Some (_,C.Decl t) -> - (*CSC: The following check seems to be wrong! *) - (*CSC: B:Set |- ?2 : Set *) - (*CSC: A:Set ; x:?2[A/B] |- ?1[x/A] =?= x *) - (*CSC: Why should I restrict ?2 over B? The instantiation *) - (*CSC: ?1 := A is perfectly reasonable and well-typed. *) - (*CSC: Thus I comment out the following two lines that *) - (*CSC: are the incriminated ones. *) - (*(* It may augment to_be_restricted *) - ignore (deliftaux k (S.lift m t)) ;*) - (*CSC: end of bug commented out *) - C.Rel ((position (m-k) l) + k) - | None -> raise (MetaSubstFailure "RelToHiddenHypothesis")) + (try + match List.nth context (m-k-1) with + Some (_,C.Def (t,_)) -> + (*CSC: Hmmm. This bit of reduction is not in the spirit of *) + (*CSC: first order unification. Does it help or does it harm? *) + deliftaux k (S.lift m t) + | Some (_,C.Decl t) -> + C.Rel ((position (m-k) l) + k) + | None -> raise (MetaSubstFailure "RelToHiddenHypothesis") + with + Failure _ -> + raise (MetaSubstFailure "Unbound variable found in deliftaux") + ) | C.Var (uri,exp_named_subst) -> let exp_named_subst' = List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst @@ -257,7 +530,7 @@ let delift n subst context metasenv l t = if i = n then raise (MetaSubstFailure (sprintf "Cannot unify the metavariable ?%d with a term that has as subterm %s in which the same metavariable occurs (occur check)" - i (CicPp.ppterm t))) + i (ppterm subst t))) else (* I do not consider the term associated to ?i in subst since *) (* in this way I can restrict if something goes wrong. *) @@ -277,7 +550,7 @@ let delift n subst context metasenv l t = let l' = deliftl 1 l1 in C.Meta(i,l') | C.Sort _ as t -> t - | C.Implicit as t -> t + | C.Implicit _ as t -> t | C.Cast (te,ty) -> C.Cast (deliftaux k te, deliftaux k ty) | C.Prod (n,s,t) -> C.Prod (n, deliftaux k s, deliftaux (k+1) t) | C.Lambda (n,s,t) -> C.Lambda (n, deliftaux k s, deliftaux (k+1) t) @@ -328,13 +601,13 @@ let delift n subst context metasenv l t = (* The reason is that our delift function is weaker than first *) (* order (in the sense of alpha-conversion). See comment above *) (* related to the delift function. *) -debug_print "!!!!!!!!!!! First Order UnificationFailure, but maybe it could have been successful even in a first order setting (no conversion, only alpha convertibility)! Please, implement a better delift function !!!!!!!!!!!!!!!!" ; - raise (MetaSubstFailure (sprintf +debug_print "\n!!!!!!!!!!! First Order UnificationFailure, but maybe it could have been successful even in a first order setting (no conversion, only alpha convertibility)! Please, implement a better delift function !!!!!!!!!!!!!!!!" ; + raise (Uncertain (sprintf "Error trying to abstract %s over [%s]: the algorithm only tried to abstract over bound variables" - (CicPp.ppterm t) + (ppterm subst t) (String.concat "; " (List.map - (function Some t -> CicPp.ppterm t | None -> "_") + (function Some t -> ppterm subst t | None -> "_") l)))) in let (metasenv, subst) = restrict subst !to_be_restricted metasenv in @@ -343,234 +616,15 @@ debug_print "!!!!!!!!!!! First Order UnificationFailure, but maybe it could have (**** END OF DELIFT ****) -let apply_subst_gen ~appl_fun subst term = - let rec um_aux = - let module C = Cic in - let module S = CicSubstitution in - function - C.Rel _ as t -> t - | C.Var _ as t -> t - | C.Meta (i, l) -> - (try - let t = List.assoc i subst in - um_aux (S.lift_meta l t) - with Not_found -> (* not constrained variable, i.e. free in subst*) - let l' = - List.map (function None -> None | Some t -> Some (um_aux t)) l - in - C.Meta (i,l')) - | C.Sort _ as t -> t - | C.Implicit -> assert false - | C.Cast (te,ty) -> C.Cast (um_aux te, um_aux ty) - | C.Prod (n,s,t) -> C.Prod (n, um_aux s, um_aux t) - | C.Lambda (n,s,t) -> C.Lambda (n, um_aux s, um_aux t) - | C.LetIn (n,s,t) -> C.LetIn (n, um_aux s, um_aux t) - | C.Appl (hd :: tl) -> appl_fun um_aux hd tl - | C.Appl _ -> assert false - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst - in - C.Const (uri, exp_named_subst') - | C.MutInd (uri,typeno,exp_named_subst) -> - let exp_named_subst' = - List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst - in - C.MutInd (uri,typeno,exp_named_subst') - | C.MutConstruct (uri,typeno,consno,exp_named_subst) -> - let exp_named_subst' = - List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst - in - C.MutConstruct (uri,typeno,consno,exp_named_subst') - | C.MutCase (sp,i,outty,t,pl) -> - let pl' = List.map um_aux pl in - C.MutCase (sp, i, um_aux outty, um_aux t, pl') - | C.Fix (i, fl) -> - let fl' = - List.map (fun (name, i, ty, bo) -> (name, i, um_aux ty, um_aux bo)) fl - in - C.Fix (i, fl') - | C.CoFix (i, fl) -> - let fl' = - List.map (fun (name, ty, bo) -> (name, um_aux ty, um_aux bo)) fl - in - C.CoFix (i, fl') - in - um_aux term - -let apply_subst = - let appl_fun um_aux he tl = - let tl' = List.map um_aux tl in - begin - match um_aux he with - Cic.Appl l -> Cic.Appl (l@tl') - | he' -> Cic.Appl (he'::tl') - end - in - apply_subst_gen ~appl_fun -let ppterm subst term = CicPp.ppterm (apply_subst subst term) +(** {2 Format-like pretty printers} *) -(* apply_subst_reducing subst (Some (mtr,reductions_no)) t *) -(* performs as (apply_subst subst t) until it finds an application of *) -(* (META [meta_to_reduce]) that, once unwinding is performed, creates *) -(* a new beta-redex; in this case up to [reductions_no] consecutive *) -(* beta-reductions are performed. *) -(* Hint: this function is usually called when [reductions_no] *) -(* eta-expansions have been performed and the head of the new *) -(* application has been unified with (META [meta_to_reduce]): *) -(* during the unwinding the eta-expansions are undone. *) - -let apply_subst_reducing meta_to_reduce = - let appl_fun um_aux he tl = - let tl' = List.map um_aux tl in - let t' = - match um_aux he with - Cic.Appl l -> Cic.Appl (l@tl') - | he' -> Cic.Appl (he'::tl') - in - begin - match meta_to_reduce, he with - Some (mtr,reductions_no), Cic.Meta (m,_) when m = mtr -> - let rec beta_reduce = - function - (n,(Cic.Appl (Cic.Lambda (_,_,t)::he'::tl'))) when n > 0 -> - let he'' = CicSubstitution.subst he' t in - if tl' = [] then - he'' - else - beta_reduce (n-1,Cic.Appl(he''::tl')) - | (_,t) -> t - in - beta_reduce (reductions_no,t') - | _,_ -> t' - end - in - apply_subst_gen ~appl_fun +let fpp_gen ppf s = + Format.pp_print_string ppf s; + Format.pp_print_newline ppf (); + Format.pp_print_flush ppf () -let rec apply_subst_context subst context = - List.fold_right - (fun item context -> - match item with - | Some (n, Cic.Decl t) -> - let t' = apply_subst subst t in - Some (n, Cic.Decl t') :: context - | Some (n, Cic.Def (t, ty)) -> - let ty' = - match ty with - | None -> None - | Some ty -> Some (apply_subst subst ty) - in - let t' = apply_subst subst t in - Some (n, Cic.Def (t', ty')) :: context - | None -> None :: context) - context [] - -let apply_subst_metasenv subst metasenv = - List.map - (fun (n, context, ty) -> - (n, apply_subst_context subst context, apply_subst subst ty)) - (List.filter - (fun (i, _, _) -> not (List.exists (fun (j, _) -> (j = i)) subst)) - metasenv) - -let ppterm subst term = CicPp.ppterm (apply_subst subst term) - -let ppterm_in_context subst term name_context = - CicPp.pp (apply_subst subst term) name_context - -let ppcontext' ?(sep = "\n") subst context = - let separate s = if s = "" then "" else s ^ sep in - List.fold_right - (fun context_entry (i,name_context) -> - match context_entry with - Some (n,Cic.Decl t) -> - sprintf "%s%s : %s" (separate i) (CicPp.ppname n) - (ppterm_in_context subst t name_context), (Some n)::name_context - | Some (n,Cic.Def (bo,ty)) -> - sprintf "%s%s : %s := %s" (separate i) (CicPp.ppname n) - (match ty with - None -> "_" - | Some ty -> ppterm_in_context subst ty name_context) - (ppterm_in_context subst bo name_context), (Some n)::name_context - | None -> - sprintf "%s_ :? _" (separate i), None::name_context - ) context ("",[]) - -let ppcontext ?sep subst context = fst (ppcontext' ?sep subst context) - -let ppmetasenv ?(sep = "\n") metasenv subst = - String.concat sep - (List.map - (fun (i, c, t) -> - let context,name_context = ppcontext' ~sep:"; " subst c in - sprintf "%s |- ?%d: %s" context i - (ppterm_in_context subst t name_context)) - (List.filter - (fun (i, _, _) -> not (List.exists (fun (j, _) -> (j = i)) subst)) - metasenv)) - -(* UNWIND THE MGU INSIDE THE MGU *) -(* -let unwind_subst metasenv subst = - List.fold_left - (fun (unwinded,metasenv) (i,_) -> - let (_,canonical_context,_) = CicUtil.lookup_meta i metasenv in - let identity_relocation_list = - CicMkImplicit.identity_relocation_list_for_metavariable canonical_context - in - let (_,metasenv',subst') = - unwind metasenv subst unwinded (Cic.Meta (i,identity_relocation_list)) - in - subst',metasenv' - ) ([],metasenv) subst -*) - -(* From now on we recreate a kernel abstraction where substitutions are part of - * the calculus *) - -let lift subst n term = - let term = apply_subst subst term in - try - CicSubstitution.lift n term - with e -> - raise (MetaSubstFailure ("Lift failure: " ^ Printexc.to_string e)) - -let subst subst t1 t2 = - let t1 = apply_subst subst t1 in - let t2 = apply_subst subst t2 in - try - CicSubstitution.subst t1 t2 - with e -> - raise (MetaSubstFailure ("Subst failure: " ^ Printexc.to_string e)) - -let whd subst context term = - let term = apply_subst subst term in - let context = apply_subst_context subst context in - try - CicReduction.whd context term - with e -> - raise (MetaSubstFailure ("Weak head reduction failure: " ^ - Printexc.to_string e)) - -let are_convertible subst context t1 t2 = - let context = apply_subst_context subst context in - let t1 = apply_subst subst t1 in - let t2 = apply_subst subst t2 in - CicReduction.are_convertible context t1 t2 - -let type_of_aux' metasenv subst context term = - let term = apply_subst subst term in - let context = apply_subst_context subst context in - let metasenv = - List.map - (fun (i, c, t) -> (i, apply_subst_context subst c, apply_subst subst t)) - (List.filter - (fun (i, _, _) -> not (List.exists (fun (j, _) -> (j = i)) subst)) - metasenv) - in - try - CicTypeChecker.type_of_aux' metasenv context term - with CicTypeChecker.TypeCheckerFailure msg -> - raise (MetaSubstFailure ("Type checker failure: " ^ msg)) +let fppsubst ppf subst = fpp_gen ppf (ppsubst subst) +let fppterm ppf term = fpp_gen ppf (CicPp.ppterm term) +let fppmetasenv ppf metasenv = fpp_gen ppf (ppmetasenv metasenv [])