+ List.fold_right
+ (fun (uri, t) (b,subst) ->
+ let b1,t = aux t in
+ b||b1,(uri, t)::subst) subst (false,[])
+ in
+ snd (aux term)
+
+exception Fail of string Lazy.t
+
+ (** select metasenv conjecture pattern
+ * select all subterms of [conjecture] matching [pattern].
+ * It returns the set of matched terms (that can be compared using physical
+ * equality to the subterms of [conjecture]) together with their contexts.
+ * The representation of the set mimics the ProofEngineTypes.pattern type:
+ * a list of hypothesis (names of) together with the list of its matched
+ * subterms (and their contexts) + the list of matched subterms of the
+ * with their context conclusion. Note: in the result the list of hypothesis
+ * has an entry for each entry in the context and in the same order.
+ * Of course the list of terms (with their context) associated to the
+ * hypothesis name may be empty.
+ *
+ * @raise Bad_pattern
+ * *)
+ let select ~metasenv ~ugraph ~conjecture:(_,context,ty)
+ ~(pattern: (Cic.term, Cic.lazy_term) ProofEngineTypes.pattern)
+ =
+ let what, hyp_patterns, goal_pattern = pattern in
+ let find_pattern_for name =
+ try Some (snd (List.find (fun (n, pat) -> Cic.Name n = name) hyp_patterns))
+ with Not_found -> None in
+ let subst,metasenv,ugraph,ty_terms =
+ select_in_term ~metasenv ~context ~ugraph ~term:ty
+ ~pattern:(what,goal_pattern) in
+ let subst,metasenv,ugraph,context_terms =
+ let subst,metasenv,ugraph,res,_ =
+ (List.fold_right
+ (fun entry (subst,metasenv,ugraph,res,context) ->
+ match entry with
+ None -> subst,metasenv,ugraph,(None::res),(None::context)
+ | Some (name,Cic.Decl term) ->
+ (match find_pattern_for name with
+ | None ->
+ subst,metasenv,ugraph,((Some (`Decl []))::res),(entry::context)
+ | Some pat ->
+ let subst,metasenv,ugraph,terms =
+ select_in_term ~metasenv ~context ~ugraph ~term
+ ~pattern:(what, Some pat)
+ in
+ subst,metasenv,ugraph,((Some (`Decl terms))::res),
+ (entry::context))
+ | Some (name,Cic.Def (bo, ty)) ->
+ (match find_pattern_for name with
+ | None ->
+ let selected_ty=match ty with None -> None | Some _ -> Some [] in
+ subst,metasenv,ugraph,((Some (`Def ([],selected_ty)))::res),
+ (entry::context)
+ | Some pat ->
+ let subst,metasenv,ugraph,terms_bo =
+ select_in_term ~metasenv ~context ~ugraph ~term:bo
+ ~pattern:(what, Some pat) in
+ let subst,metasenv,ugraph,terms_ty =
+ match ty with
+ None -> subst,metasenv,ugraph,None
+ | Some ty ->
+ let subst,metasenv,ugraph,res =
+ select_in_term ~metasenv ~context ~ugraph ~term:ty
+ ~pattern:(what, Some pat)
+ in
+ subst,metasenv,ugraph,Some res
+ in
+ subst,metasenv,ugraph,((Some (`Def (terms_bo,terms_ty)))::res),
+ (entry::context))
+ ) context (subst,metasenv,ugraph,[],[]))
+ in
+ subst,metasenv,ugraph,res
+ in
+ subst,metasenv,ugraph,context_terms, ty_terms
+
+(** locate_in_term equality what where context
+* [what] must match a subterm of [where] according to [equality]
+* It returns the matched terms together with their contexts in [where]
+* [equality] defaults to physical equality
+* [context] must be the context of [where]
+*)
+let locate_in_term ?(equality=(fun _ -> (==))) what ~where context =
+ let add_ctx context name entry =
+ (Some (name, entry)) :: context in
+ let rec aux context where =
+ if equality context what where then [context,where]
+ else
+ match where with
+ | Cic.Implicit _
+ | Cic.Meta _
+ | Cic.Rel _
+ | Cic.Sort _
+ | Cic.Var _
+ | Cic.Const _
+ | Cic.MutInd _
+ | Cic.MutConstruct _ -> []
+ | Cic.Cast (te, ty) -> aux context te @ aux context ty
+ | Cic.Prod (name, s, t)
+ | Cic.Lambda (name, s, t) ->
+ aux context s @ aux (add_ctx context name (Cic.Decl s)) t
+ | Cic.LetIn (name, s, t) ->
+ aux context s @ aux (add_ctx context name (Cic.Def (s,None))) t
+ | Cic.Appl tl -> auxs context tl
+ | Cic.MutCase (_, _, out, t, pat) ->
+ aux context out @ aux context t @ auxs context pat
+ | Cic.Fix (_, funs) ->
+ let tys =
+ List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funs
+ in
+ List.concat
+ (List.map
+ (fun (_, _, ty, bo) ->
+ aux context ty @ aux (tys @ context) bo)
+ funs)
+ | Cic.CoFix (_, funs) ->
+ let tys =
+ List.map (fun (n,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funs
+ in
+ List.concat
+ (List.map
+ (fun (_, ty, bo) ->
+ aux context ty @ aux (tys @ context) bo)
+ funs)
+ and auxs context tl = (* as aux for list of terms *)
+ List.concat (List.map (fun t -> aux context t) tl)