diff options
Diffstat (limited to 'interp')
| -rw-r--r-- | interp/constrextern.ml | 5 | ||||
| -rw-r--r-- | interp/constrintern.ml | 103 | ||||
| -rw-r--r-- | interp/notation_ops.ml | 325 | ||||
| -rw-r--r-- | interp/notation_ops.mli | 6 |
4 files changed, 346 insertions, 93 deletions
diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 7476871890..e71daef999 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -848,10 +848,11 @@ and extern_local_binder scopes vars = function | (Inr p,bk,Some bd,ty)::l -> assert false | (Inr p,bk,None,ty)::l -> - let ty = extern_typ scopes vars ty in + let ty = + if !Flags.raw_print then Some (extern_typ scopes vars ty) else None in let p = extern_cases_pattern vars p in let (assums,ids,l) = extern_local_binder scopes vars l in - (assums,ids, LocalPattern(Loc.ghost,p,Some ty) :: l) + (assums,ids, LocalPattern(Loc.ghost,p,ty) :: l) and extern_eqn inctx scopes vars (loc,ids,pl,c) = (loc,[loc,List.map (extern_cases_pattern_in_scope scopes vars) pl], diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 1c50253d9c..fb1baae0a8 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -481,9 +481,14 @@ let intern_local_binder_aux ?(global_level=false) intern lvar (env,bl) = functio let bl' = List.map (fun a -> BDRawDef a) bl' in env, bl' @ bl | LocalRawDef((loc,na as locna),def) -> - let indef = intern env def in + let indef = intern env def in + let term, ty = + match indef with + | GCast (loc, b, Misctypes.CastConv t) -> b, t + | _ -> indef, GHole(loc,Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None) + in (push_name_env lvar (impls_term_list indef) env locna, - (BDRawDef ((loc,(na,Explicit,Some(indef),GHole(loc,Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None)))))::bl) + (BDRawDef ((loc,(na,Explicit,Some(term),ty))))::bl) | LocalPattern (loc,p,ty) -> let tyc = match ty with @@ -599,31 +604,52 @@ let rec subordinate_letins intern letins = function | [] -> letins,[] -let rec subst_iterator y t = function - | GVar (_,id) as x -> if Id.equal id y then t else x - | x -> map_glob_constr (subst_iterator y t) x +let terms_of_binders bl = + let rec term_of_pat = function + | PatVar (loc,Name id) -> CRef (Ident (loc,id), None) + | PatVar (loc,Anonymous) -> error "Cannot turn \"_\" into a term." + | PatCstr (loc,c,l,_) -> + let r = Qualid (loc,qualid_of_path (path_of_global (ConstructRef c))) in + let hole = CHole (loc,None,Misctypes.IntroAnonymous,None) in + let params = List.make (Inductiveops.inductive_nparams (fst c)) hole in + CAppExpl (loc,(None,r,None),params @ List.map term_of_pat l) in + let rec extract_variables = function + | BDRawDef (loc,(Name id,_,None,_))::l -> CRef (Ident (loc,id), None) :: extract_variables l + | BDRawDef (loc,(Name id,_,Some _,_))::l -> extract_variables l + | BDRawDef (loc,(Anonymous,_,_,_))::l -> error "Cannot turn \"_\" into a term." + | BDPattern (loc,(u,_),lvar,env,tyc) :: l -> term_of_pat u :: extract_variables l + | [] -> [] in + extract_variables bl let instantiate_notation_constr loc intern ntnvars subst infos c = let (terms,termlists,binders) = subst in (* when called while defining a notation, avoid capturing the private binders of the expression by variables bound by the notation (see #3892) *) let avoid = Id.Map.domain ntnvars in - let rec aux (terms,binderopt as subst') (renaming,env) c = + let rec aux (terms,binderopt,terminopt as subst') (renaming,env) c = let subinfos = renaming,{env with tmp_scope = None} in match c with + | NVar id when Id.equal id ldots_var -> Option.get terminopt | NVar id -> subst_var subst' (renaming, env) id - | NList (x,_,iter,terminator,lassoc) -> - (try + | NList (x,y,iter,terminator,lassoc) -> + let l,(scopt,subscopes) = (* All elements of the list are in scopes (scopt,subscopes) *) - let (l,(scopt,subscopes)) = Id.Map.find x termlists in - let termin = aux subst' subinfos terminator in - let fold a t = - let nterms = Id.Map.add x (a, (scopt, subscopes)) terms in - subst_iterator ldots_var t (aux (nterms, binderopt) subinfos iter) - in - List.fold_right fold (if lassoc then List.rev l else l) termin - with Not_found -> - anomaly (Pp.str "Inconsistent substitution of recursive notation")) + try + let l,scopes = Id.Map.find x termlists in + (if lassoc then List.rev l else l),scopes + with Not_found -> + try + let (bl,(scopt,subscopes)) = Id.Map.find x binders in + let env,bl' = List.fold_left (intern_local_binder_aux intern ntnvars) (env,[]) bl in + terms_of_binders (if lassoc then bl' else List.rev bl'),(None,[]) + with Not_found -> + anomaly (Pp.str "Inconsistent substitution of recursive notation") in + let termin = aux (terms,None,None) subinfos terminator in + let fold a t = + let nterms = Id.Map.add y (a, (scopt, subscopes)) terms in + aux (nterms,None,Some t) subinfos iter + in + List.fold_right fold l termin | NHole (knd, naming, arg) -> let knd = match knd with | Evar_kinds.BinderType (Name id as na) -> @@ -658,16 +684,15 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = Some arg in GHole (loc, knd, naming, arg) - | NBinderList (x,_,iter,terminator) -> + | NBinderList (x,y,iter,terminator) -> (try (* All elements of the list are in scopes (scopt,subscopes) *) let (bl,(scopt,subscopes)) = Id.Map.find x binders in let env,bl = List.fold_left (intern_local_binder_aux intern ntnvars) (env,[]) bl in let letins,bl = subordinate_letins intern [] bl in - let termin = aux subst' (renaming,env) terminator in + let termin = aux (terms,None,None) (renaming,env) terminator in let res = List.fold_left (fun t binder -> - subst_iterator ldots_var t - (aux (terms,Some(x,binder)) subinfos iter)) + aux (terms,Some(y,binder),Some t) subinfos iter) termin bl in make_letins letins res with Not_found -> @@ -695,7 +720,7 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = | t -> glob_constr_of_notation_constr_with_binders loc (traverse_binder subst avoid) (aux subst') subinfos t - and subst_var (terms, binderopt) (renaming, env) id = + and subst_var (terms, _binderopt, _terminopt) (renaming, env) id = (* subst remembers the delimiters stack in the interpretation *) (* of the notations *) try @@ -708,7 +733,7 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = with Not_found -> (* Happens for local notation joint with inductive/fixpoint defs *) GVar (loc,id) - in aux (terms,None) infos c + in aux (terms,None,None) infos c let split_by_type ids = List.fold_right (fun (x,(scl,typ)) (l1,l2,l3) -> @@ -1324,7 +1349,7 @@ let drop_notations_pattern looked_for = RCPatCstr (loc, g, List.map2 (fun x -> in_not false loc (x,snd scopes) fullsubst []) argscs1 pl @ List.map (in_pat false scopes) args, []) - | NList (x,_,iter,terminator,lassoc) -> + | NList (x,y,iter,terminator,lassoc) -> if not (List.is_empty args) then user_err_loc (loc,"",strbrk "Application of arguments to a recursive notation not supported in patterns."); (try @@ -1332,7 +1357,7 @@ let drop_notations_pattern looked_for = let (l,(scopt,subscopes)) = Id.Map.find x substlist in let termin = in_not top loc scopes fullsubst [] terminator in List.fold_right (fun a t -> - let nsubst = Id.Map.add x (a, (scopt, subscopes)) subst in + let nsubst = Id.Map.add y (a, (scopt, subscopes)) subst in let u = in_not false loc scopes (nsubst, substlist) [] iter in subst_pat_iterator ldots_var t u) (if lassoc then List.rev l else l) termin @@ -1609,11 +1634,13 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = (merge_impargs l args) loc | CRecord (loc, fs) -> - let fields = - sort_fields ~complete:true loc fs - (fun _idx -> CHole (loc, Some (Evar_kinds.QuestionMark (Evar_kinds.Define true)), Misctypes.IntroAnonymous, None)) - in - begin + let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in + let fields = + sort_fields ~complete:true loc fs + (fun _idx -> CHole (loc, Some (Evar_kinds.QuestionMark st), + Misctypes.IntroAnonymous, None)) + in + begin match fields with | None -> user_err_loc (loc, "intern", str"No constructor inference.") | Some (n, constrname, args) -> @@ -1683,7 +1710,9 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = GIf (loc, c', (na', p'), intern env b1, intern env b2) | CHole (loc, k, naming, solve) -> let k = match k with - | None -> Evar_kinds.QuestionMark (Evar_kinds.Define true) + | None -> + let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in + Evar_kinds.QuestionMark st | Some k -> k in let solve = match solve with @@ -2030,11 +2059,13 @@ let interp_rawcontext_evars env evdref k bl = let (env, par, _, impls) = List.fold_left (fun (env,params,n,impls) (na, k, b, t) -> + let t' = + if Option.is_empty b then locate_if_hole (loc_of_glob_constr t) na t + else t + in + let t = understand_tcc_evars env evdref ~expected_type:IsType t' in match b with None -> - let t' = locate_if_hole (loc_of_glob_constr t) na t in - let t = - understand_tcc_evars env evdref ~expected_type:IsType t' in let d = LocalAssum (na,t) in let impls = if k == Implicit then @@ -2044,8 +2075,8 @@ let interp_rawcontext_evars env evdref k bl = in (push_rel d env, d::params, succ n, impls) | Some b -> - let c = understand_judgment_tcc env evdref b in - let d = LocalDef (na, c.uj_val, c.uj_type) in + let c = understand_tcc_evars env evdref ~expected_type:(OfType t) b in + let d = LocalDef (na, c, t) in (push_rel d env, d::params, n, impls)) (env,[],k+1,[]) (List.rev bl) in (env, par), impls diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 198bd2216a..f3e0682bd7 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -237,7 +237,9 @@ let check_is_hole id = function GHole _ -> () | t -> strbrk "In recursive notation with binders, " ++ pr_id id ++ strbrk " is expected to come without type.") -let compare_recursive_parts found f (iterator,subc) = +let pair_equal eq1 eq2 (a,b) (a',b') = eq1 a a' && eq2 b b' + +let compare_recursive_parts found f f' (iterator,subc) = let diff = ref None in let terminator = ref None in let rec aux c1 c2 = match c1,c2 with @@ -284,16 +286,26 @@ let compare_recursive_parts found f (iterator,subc) = user_err_loc (subtract_loc loc1 loc2,"", str "Both ends of the recursive pattern are the same.") | Some (x,y,Some lassoc) -> - let newfound = (pi1 !found, (x,y) :: pi2 !found, pi3 !found) in + let newfound,x,y,lassoc = + if List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi2 !found) || + List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi3 !found) + then + !found,x,y,lassoc + else if List.mem_f (pair_equal Id.equal Id.equal) (y,x) (pi2 !found) || + List.mem_f (pair_equal Id.equal Id.equal) (y,x) (pi3 !found) + then + !found,y,x,not lassoc + else + (pi1 !found, (x,y) :: pi2 !found, pi3 !found),x,y,lassoc in let iterator = - f (if lassoc then subst_glob_vars [y,GVar(Loc.ghost,x)] iterator - else iterator) in + f' (if lassoc then iterator + else subst_glob_vars [x,GVar(Loc.ghost,y)] iterator) in (* found have been collected by compare_constr *) found := newfound; NList (x,y,iterator,f (Option.get !terminator),lassoc) | Some (x,y,None) -> let newfound = (pi1 !found, pi2 !found, (x,y) :: pi3 !found) in - let iterator = f iterator in + let iterator = f' (subst_glob_vars [x,GVar(Loc.ghost,y)] iterator) in (* found have been collected by compare_constr *) found := newfound; NBinderList (x,y,iterator,f (Option.get !terminator)) @@ -305,7 +317,7 @@ let notation_constr_and_vars_of_glob_constr a = let rec aux c = let keepfound = !found in (* n^2 complexity but small and done only once per notation *) - try compare_recursive_parts found aux' (split_at_recursive_part c) + try compare_recursive_parts found aux aux' (split_at_recursive_part c) with Not_found -> found := keepfound; match c with @@ -357,8 +369,6 @@ let notation_constr_and_vars_of_glob_constr a = (* Side effect *) t, !found -let pair_equal eq1 eq2 (a,b) (a',b') = eq1 a a' && eq2 b b' - let check_variables nenv (found,foundrec,foundrecbinding) = let recvars = nenv.ninterp_rec_vars in let fold _ y accu = Id.Set.add y accu in @@ -585,6 +595,10 @@ let rec alpha_var id1 id2 = function | _::idl -> alpha_var id1 id2 idl | [] -> Id.equal id1 id2 +let alpha_rename alpmetas v = + if alpmetas == [] then v + else try rename_glob_vars alpmetas v with UnsoundRenaming -> raise No_match + let add_env (alp,alpmetas) (terms,onlybinders,termlists,binderlists) var v = (* Check that no capture of binding variables occur *) (* [alp] is used when matching a pattern "fun x => ... x ... ?var ... x ..." @@ -610,16 +624,29 @@ let add_env (alp,alpmetas) (terms,onlybinders,termlists,binderlists) var v = glob_constr_eq in bind_term_env to be postponed in match_notation_constr, and the choice of exact variable be done there; but again, this would be a non-trivial refinement *) - if alpmetas != [] then raise No_match; + let v = alpha_rename alpmetas v in (* TODO: handle the case of multiple occs in different scopes *) ((var,v)::terms,onlybinders,termlists,binderlists) +let add_termlist_env (alp,alpmetas) (terms,onlybinders,termlists,binderlists) var vl = + if List.exists (fun (id,_) -> List.exists (occur_glob_constr id) vl) alp then raise No_match; + let vl = List.map (alpha_rename alpmetas) vl in + (terms,onlybinders,(var,vl)::termlists,binderlists) + let add_binding_env alp (terms,onlybinders,termlists,binderlists) var v = (* TODO: handle the case of multiple occs in different scopes *) (terms,(var,v)::onlybinders,termlists,binderlists) let add_bindinglist_env (terms,onlybinders,termlists,binderlists) x bl = - (terms,onlybinders,termlists,(x,List.rev bl)::binderlists) + (terms,onlybinders,termlists,(x,bl)::binderlists) + +let rec pat_binder_of_term = function + | GVar (loc, id) -> PatVar (loc, Name id) + | GApp (loc, GRef (_,ConstructRef cstr,_), l) -> + let nparams = Inductiveops.inductive_nparams (fst cstr) in + let _,l = List.chop nparams l in + PatCstr (loc, cstr, List.map pat_binder_of_term l, Anonymous) + | _ -> raise No_match let bind_term_env alp (terms,onlybinders,termlists,binderlists as sigma) var v = try @@ -630,10 +657,53 @@ let bind_term_env alp (terms,onlybinders,termlists,binderlists as sigma) var v = let sigma = Id.List.remove_assoc var terms,onlybinders,termlists,binderlists in add_env alp sigma var v | _, _ -> - if glob_constr_eq v v' then sigma + if glob_constr_eq (alpha_rename (snd alp) v) v' then sigma else raise No_match with Not_found -> add_env alp sigma var v +let bind_termlist_env alp (terms,onlybinders,termlists,binderlists as sigma) var vl = + try + let vl' = Id.List.assoc var termlists in + let unify_term v v' = + match v, v' with + | GHole _, _ -> v' + | _, GHole _ -> v + | _, _ -> if glob_constr_eq (alpha_rename (snd alp) v) v' then v' else raise No_match in + let rec unify vl vl' = + match vl, vl' with + | [], [] -> [] + | v :: vl, v' :: vl' -> unify_term v v' :: unify vl vl' + | _ -> raise No_match in + let vl = unify vl vl' in + let sigma = (terms,onlybinders,Id.List.remove_assoc var termlists,binderlists) in + add_termlist_env alp sigma var vl + with Not_found -> add_termlist_env alp sigma var vl + +let bind_term_as_binding_env alp (terms,onlybinders,termlists,binderlists as sigma) var id = + try + match Id.List.assoc var terms with + | GVar (_,id') -> + (if not (Id.equal id id') then (fst alp,(id,id')::snd alp) else alp), + sigma + | _ -> anomaly (str "A term which can be a binder has to be a variable") + with Not_found -> + (* The matching against a term allowing to find the instance has not been found yet *) + (* If it will be a different name, we shall unfortunately fail *) + (* TODO: look at the consequences for alp *) + alp, add_env alp sigma var (GVar (Loc.ghost,id)) + +let bind_binding_as_term_env alp (terms,onlybinders,termlists,binderlists as sigma) var id = + try + let v' = Id.List.assoc var onlybinders in + match v' with + | Anonymous -> + (* Should not occur, since the term has to be bound upwards *) + let sigma = (terms,Id.List.remove_assoc var onlybinders,termlists,binderlists) in + add_binding_env alp sigma var (Name id) + | Name id' -> + if Id.equal (rename_var (snd alp) id) id' then sigma else raise No_match + with Not_found -> add_binding_env alp sigma var (Name id) + let bind_binding_env alp (terms,onlybinders,termlists,binderlists as sigma) var v = try let v' = Id.List.assoc var onlybinders in @@ -647,6 +717,109 @@ let bind_binding_env alp (terms,onlybinders,termlists,binderlists as sigma) var else (fst alp,(id1,id2)::snd alp),sigma with Not_found -> alp, add_binding_env alp sigma var v +let rec map_cases_pattern_name_left f = function + | PatVar (loc,na) -> PatVar (loc,f na) + | PatCstr (loc,c,l,na) -> PatCstr (loc,c,List.map_left (map_cases_pattern_name_left f) l,f na) + +let rec fold_cases_pattern_eq f x p p' = match p, p' with + | PatVar (loc,na), PatVar (_,na') -> let x,na = f x na na' in x, PatVar (loc,na) + | PatCstr (loc,c,l,na), PatCstr (_,c',l',na') when eq_constructor c c' -> + let x,l = fold_cases_pattern_list_eq f x l l' in + let x,na = f x na na' in + x, PatCstr (loc,c,l,na) + | _ -> failwith "Not equal" + +and fold_cases_pattern_list_eq f x pl pl' = match pl, pl' with + | [], [] -> x, [] + | p::pl, p'::pl' -> + let x, p = fold_cases_pattern_eq f x p p' in + let x, pl = fold_cases_pattern_list_eq f x pl pl' in + x, p :: pl + | _ -> assert false + +let rec cases_pattern_eq p1 p2 = match p1, p2 with +| PatVar (_, na1), PatVar (_, na2) -> Name.equal na1 na2 +| PatCstr (_, c1, pl1, na1), PatCstr (_, c2, pl2, na2) -> + eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && + Name.equal na1 na2 +| _ -> false + +let bind_bindinglist_env alp (terms,onlybinders,termlists,binderlists as sigma) var bl = + let bl = List.rev bl in + try + let bl' = Id.List.assoc var binderlists in + let unify_name alp na na' = + match na, na' with + | Anonymous, na' -> alp, na' + | na, Anonymous -> alp, na + | Name id, Name id' -> + if Id.equal id id' then alp, na' + else (fst alp,(id,id')::snd alp), na' in + let unify_pat alp p p' = + try fold_cases_pattern_eq unify_name alp p p' with Failure _ -> raise No_match in + let unify_term alp v v' = + match v, v' with + | GHole _, _ -> v' + | _, GHole _ -> v + | _, _ -> if glob_constr_eq (alpha_rename (snd alp) v) v' then v else raise No_match in + let unify_binding_kind bk bk' = if bk == bk' then bk' else raise No_match in + let unify_binder alp b b' = + match b, b' with + | (Inl na, bk, None, t), (Inl na', bk', None, t') (* assum *) -> + let alp, na = unify_name alp na na' in + alp, (Inl na, unify_binding_kind bk bk', None, unify_term alp t t') + | (Inl na, bk, Some c, t), (Inl na', bk', Some c', t') (* let *) -> + let alp, na = unify_name alp na na' in + alp, (Inl na, unify_binding_kind bk bk', Some (unify_term alp c c'), unify_term alp t t') + | (Inr p, bk, None, t), (Inr p', bk', None, t') (* pattern *) -> + let alp, p = unify_pat alp p p' in + alp, (Inr p, unify_binding_kind bk bk', None, unify_term alp t t') + | _ -> raise No_match in + let rec unify alp bl bl' = + match bl, bl' with + | [], [] -> alp, [] + | b :: bl, b' :: bl' -> + let alp,b = unify_binder alp b b' in + let alp,bl = unify alp bl bl' in + alp, b :: bl + | _ -> raise No_match in + let alp, bl = unify alp bl bl' in + let sigma = (terms,Id.List.remove_assoc var onlybinders,termlists,binderlists) in + alp, add_bindinglist_env sigma var bl + with Not_found -> + alp, add_bindinglist_env sigma var bl + +let bind_bindinglist_as_term_env alp (terms,onlybinders,termlists,binderlists) var cl = + try + let bl' = Id.List.assoc var binderlists in + let unify_id id na' = + match na' with + | Anonymous -> Name (rename_var (snd alp) id) + | Name id' -> + if Id.equal (rename_var (snd alp) id) id' then na' else raise No_match in + let unify_pat p p' = + if cases_pattern_eq (map_cases_pattern_name_left (name_app (rename_var (snd alp))) p) p' then p' + else raise No_match in + let unify_term_binder c b' = + match c, b' with + | GVar (_, id), (Inl na', bk', None, t') (* assum *) -> + (Inl (unify_id id na'), bk', None, t') + | c, (Inr p', bk', None, t') (* pattern *) -> + let p = pat_binder_of_term c in + (Inr (unify_pat p p'), bk', None, t') + | _ -> raise No_match in + let rec unify cl bl' = + match cl, bl' with + | [], [] -> [] + | c :: cl, (Inl _, _, Some _,t) :: bl' -> unify cl bl' + | c :: cl, b' :: bl' -> unify_term_binder c b' :: unify cl bl' + | _ -> raise No_match in + let bl = unify cl bl' in + let sigma = (terms,onlybinders,termlists,Id.List.remove_assoc var binderlists) in + add_bindinglist_env sigma var bl + with Not_found -> + anomaly (str "There should be a binder list bindings this list of terms") + let match_fix_kind fk1 fk2 = match (fk1,fk2) with | GCoFix n1, GCoFix n2 -> Int.equal n1 n2 @@ -670,8 +843,8 @@ let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with bind_binding_env alp sigma id2 na1 | (Name id1,Name id2) when is_term_meta id2 metas -> (* We let the non-binding occurrence define the rhs and hence reason up to *) - (* alpha-conversion for the given occurrence of the name (see #)) *) - (fst alp,(id1,id2)::snd alp), sigma + (* alpha-conversion for the given occurrence of the name (see #4592)) *) + bind_term_as_binding_env alp sigma id2 id1 | (Anonymous,Name id2) when is_term_meta id2 metas -> (* We let the non-binding occurrence define the rhs *) alp, sigma @@ -691,8 +864,14 @@ let rec match_cases_pattern_binders metas acc pat1 pat2 = let glue_letin_with_decls = true let rec match_iterated_binders islambda decls = function + | GLambda (_,Name p,bk,t,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,_,[cp],b)])) + when islambda && Id.equal p e -> + match_iterated_binders islambda ((Inr cp,bk,None,t)::decls) b | GLambda (_,na,bk,t,b) when islambda -> match_iterated_binders islambda ((Inl na,bk,None,t)::decls) b + | GProd (_,Name p,bk,t,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,_,[cp],b)])) + when not islambda && Id.equal p e -> + match_iterated_binders islambda ((Inr cp,bk,None,t)::decls) b | GProd (_,(Name _ as na),bk,t,b) when not islambda -> match_iterated_binders islambda ((Inl na,bk,None,t)::decls) b | GLetIn (loc,na,c,b) when glue_letin_with_decls -> @@ -703,35 +882,51 @@ let rec match_iterated_binders islambda decls = function let remove_sigma x (terms,onlybinders,termlists,binderlists) = (Id.List.remove_assoc x terms,onlybinders,termlists,binderlists) +let remove_bindinglist_sigma x (terms,onlybinders,termlists,binderlists) = + (terms,onlybinders,termlists,Id.List.remove_assoc x binderlists) + let add_ldots_var metas = (ldots_var,((None,[]),NtnTypeConstr))::metas -let match_abinderlist_with_app match_fun metas sigma rest x iter termin = - let rec aux sigma acc rest = +let add_meta_bindinglist x metas = (x,((None,[]),NtnTypeBinderList))::metas + +let match_binderlist_with_app match_fun alp metas sigma rest x y iter termin = + let rec aux sigma bl rest = try - let (terms,_,_,binderlists as sigma) = match_fun (add_ldots_var metas) sigma rest iter in + let metas = add_ldots_var (add_meta_bindinglist y metas) in + let (terms,_,_,binderlists as sigma) = match_fun alp metas sigma rest iter in let rest = Id.List.assoc ldots_var terms in let b = - match Id.List.assoc x binderlists with [b] -> b | _ ->assert false + match Id.List.assoc y binderlists with [b] -> b | _ ->assert false in - let sigma = remove_sigma x (remove_sigma ldots_var sigma) in - aux sigma (b::acc) rest - with No_match when not (List.is_empty acc) -> - acc, match_fun metas sigma rest termin in - let bl,sigma = aux sigma [] rest in - add_bindinglist_env sigma x bl + let sigma = remove_bindinglist_sigma y (remove_sigma ldots_var sigma) in + aux sigma (b::bl) rest + with No_match when not (List.is_empty bl) -> + bl, rest, sigma in + let bl,rest,sigma = aux sigma [] rest in + let alp,sigma = bind_bindinglist_env alp sigma x bl in + match_fun alp metas sigma rest termin + +let add_meta_term x metas = (x,((None,[]),NtnTypeConstr))::metas -let match_alist match_fun metas sigma rest x iter termin lassoc = +let match_termlist match_fun alp metas sigma rest x y iter termin lassoc = let rec aux sigma acc rest = try - let (terms,_,_,_ as sigma) = match_fun (add_ldots_var metas) sigma rest iter in + let metas = add_ldots_var (add_meta_term y metas) in + let (terms,_,_,_ as sigma) = match_fun metas sigma rest iter in let rest = Id.List.assoc ldots_var terms in - let t = Id.List.assoc x terms in - let sigma = remove_sigma x (remove_sigma ldots_var sigma) in + let t = Id.List.assoc y terms in + let sigma = remove_sigma y (remove_sigma ldots_var sigma) in aux sigma (t::acc) rest with No_match when not (List.is_empty acc) -> acc, match_fun metas sigma rest termin in let l,(terms,onlybinders,termlists,binderlists as sigma) = aux sigma [] rest in - (terms,onlybinders,(x,if lassoc then l else List.rev l)::termlists, binderlists) + let l = if lassoc then l else List.rev l in + if is_bindinglist_meta x metas then + (* This is a recursive pattern for both bindings and terms; it is *) + (* registered for binders *) + bind_bindinglist_as_term_env alp sigma x l + else + bind_termlist_env alp sigma x l let does_not_come_from_already_eta_expanded_var = (* This is hack to avoid looping on a rule with rhs of the form *) @@ -750,46 +945,58 @@ let rec match_ inner u alp metas sigma a1 a2 = (* Matching notation variable *) | r1, NVar id2 when is_term_meta id2 metas -> bind_term_env alp sigma id2 r1 - | GVar (_,id1), NVar id2 when is_onlybinding_meta id2 metas -> snd (bind_binding_env alp sigma id2 (Name id1)) + | GVar (_,id1), NVar id2 when is_onlybinding_meta id2 metas -> bind_binding_as_term_env alp sigma id2 id1 + | r1, NVar id2 when is_bindinglist_meta id2 metas -> bind_term_env alp sigma id2 r1 (* Matching recursive notations for terms *) - | r1, NList (x,_,iter,termin,lassoc) -> - match_alist (match_hd u alp) metas sigma r1 x iter termin lassoc + | r1, NList (x,y,iter,termin,lassoc) -> + match_termlist (match_hd u alp) alp metas sigma r1 x y iter termin lassoc (* "λ p, let 'cp = p in t" -> "λ 'cp, t" *) - | GLambda (_,Name p,bk,t1,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,_,[cp],t)])), - NBinderList (x,_,NLambda (Name id2,_,b2),(NVar v as termin)) when p = e -> - let decls = [(Inr cp,bk,None,t1)] in - match_in u alp metas (add_bindinglist_env sigma x decls) t termin + | GLambda (_,Name p,bk,t1,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,_,[cp],b1)])), + NBinderList (x,_,NLambda (Name _id2,_,b2),termin) when Id.equal p e -> + let (decls,b) = match_iterated_binders true [(Inr cp,bk,None,t1)] b1 in + let alp,sigma = bind_bindinglist_env alp sigma x decls in + match_in u alp metas sigma b termin (* Matching recursive notations for binders: ad hoc cases supporting let-in *) - | GLambda (_,na1,bk,t1,b1), NBinderList (x,_,NLambda (Name id2,_,b2),termin)-> + | GLambda (_,na1,bk,t1,b1), NBinderList (x,_,NLambda (Name _id2,_,b2),termin)-> let (decls,b) = match_iterated_binders true [(Inl na1,bk,None,t1)] b1 in (* TODO: address the possibility that termin is a Lambda itself *) - match_in u alp metas (add_bindinglist_env sigma x decls) b termin + let alp,sigma = bind_bindinglist_env alp sigma x decls in + match_in u alp metas sigma b termin (* "∀ p, let 'cp = p in t" -> "∀ 'cp, t" *) - | GProd (_,Name p,bk,t1,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,_,[cp],t)])), - NBinderList (x,_,NProd (Name id2,_,b2),(NVar v as termin)) when p = e -> - let decls = [(Inr cp,bk,None,t1)] in - match_in u alp metas (add_bindinglist_env sigma x decls) t termin + | GProd (_,Name p,bk,t1,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,_,[cp],b1)])), + NBinderList (x,_,NProd (Name _id2,_,b2),(NVar v as termin)) when Id.equal p e -> + let (decls,b) = match_iterated_binders true [(Inr cp,bk,None,t1)] b1 in + let alp,sigma = bind_bindinglist_env alp sigma x decls in + match_in u alp metas sigma b termin - | GProd (_,na1,bk,t1,b1), NBinderList (x,_,NProd (Name id2,_,b2),termin) + | GProd (_,na1,bk,t1,b1), NBinderList (x,_,NProd (Name _id2,_,b2),termin) when na1 != Anonymous -> let (decls,b) = match_iterated_binders false [(Inl na1,bk,None,t1)] b1 in (* TODO: address the possibility that termin is a Prod itself *) - match_in u alp metas (add_bindinglist_env sigma x decls) b termin + let alp,sigma = bind_bindinglist_env alp sigma x decls in + match_in u alp metas sigma b termin (* Matching recursive notations for binders: general case *) - | r, NBinderList (x,_,iter,termin) -> - match_abinderlist_with_app (match_hd u alp) metas sigma r x iter termin + | r, NBinderList (x,y,iter,termin) -> + match_binderlist_with_app (match_hd u) alp metas sigma r x y iter termin (* Matching individual binders as part of a recursive pattern *) + | GLambda (_,Name p,bk,t,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,_,[cp],b1)])), + NLambda (Name id,_,b2) + when is_bindinglist_meta id metas -> + let alp,sigma = bind_bindinglist_env alp sigma id [(Inr cp,bk,None,t)] in + match_in u alp metas sigma b1 b2 | GLambda (_,na,bk,t,b1), NLambda (Name id,_,b2) when is_bindinglist_meta id metas -> - match_in u alp metas (add_bindinglist_env sigma id [(Inl na,bk,None,t)]) b1 b2 + let alp,sigma = bind_bindinglist_env alp sigma id [(Inl na,bk,None,t)] in + match_in u alp metas sigma b1 b2 | GProd (_,na,bk,t,b1), NProd (Name id,_,b2) when is_bindinglist_meta id metas && na != Anonymous -> - match_in u alp metas (add_bindinglist_env sigma id [(Inl na,bk,None,t)]) b1 b2 + let alp,sigma = bind_bindinglist_env alp sigma id [(Inl na,bk,None,t)] in + match_in u alp metas sigma b1 b2 (* Matching compositionally *) | GVar (_,id1), NVar id2 when alpha_var id1 id2 (fst alp) -> sigma @@ -876,7 +1083,7 @@ let rec match_ inner u alp metas sigma a1 a2 = | _ -> assert false in let (alp,sigma) = if is_bindinglist_meta id metas then - alp, add_bindinglist_env sigma id [(Inl (Name id'),Explicit,None,t1)] + bind_bindinglist_env alp sigma id [(Inl (Name id'),Explicit,None,t1)] else match_names metas (alp,sigma) (Name id') na in match_in u alp metas sigma (mkGApp Loc.ghost b1 (GVar (Loc.ghost,id'))) b2 @@ -944,7 +1151,21 @@ let bind_env_cases_pattern (terms,x,termlists,y as sigma) var v = (* TODO: handle the case of multiple occs in different scopes *) (var,v)::terms,x,termlists,y -let rec match_cases_pattern metas (terms,x,termlists,y as sigma) a1 a2 = +let match_cases_pattern_list match_fun metas sigma rest x y iter termin lassoc = + let rec aux sigma acc rest = + try + let metas = add_ldots_var (add_meta_term y metas) in + let (terms,_,_,_ as sigma) = match_fun metas sigma rest iter in + let rest = Id.List.assoc ldots_var terms in + let t = Id.List.assoc y terms in + let sigma = remove_sigma y (remove_sigma ldots_var sigma) in + aux sigma (t::acc) rest + with No_match when not (List.is_empty acc) -> + acc, match_fun metas sigma rest termin in + let l,(terms,onlybinders,termlists,binderlists as sigma) = aux sigma [] rest in + (terms,onlybinders,(x,if lassoc then l else List.rev l)::termlists, binderlists) + +let rec match_cases_pattern metas (terms,(),termlists,() as sigma) a1 a2 = match (a1,a2) with | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 r1),(0,[]) | PatVar (_,Anonymous), NHole _ -> sigma,(0,[]) @@ -960,9 +1181,9 @@ let rec match_cases_pattern metas (terms,x,termlists,y as sigma) a1 a2 = else let l1',more_args = Util.List.chop le2 l1 in (List.fold_left2 (match_cases_pattern_no_more_args metas) sigma l1' l2),(le2,more_args) - | r1, NList (x,_,iter,termin,lassoc) -> - (match_alist (match_cases_pattern_no_more_args) - metas (terms,(),termlists,()) r1 x iter termin lassoc),(0,[]) + | r1, NList (x,y,iter,termin,lassoc) -> + (match_cases_pattern_list (match_cases_pattern_no_more_args) + metas (terms,(),termlists,()) r1 x y iter termin lassoc),(0,[]) | _ -> raise No_match and match_cases_pattern_no_more_args metas sigma a1 a2 = diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index 0f1b1a8756..854e222e30 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -23,7 +23,7 @@ val subst_interpretation : val ldots_var : Id.t -(** {5 Translation back and forth between [glob_constr] and [notation_constr] *) +(** {5 Translation back and forth between [glob_constr] and [notation_constr]} *) (** Translate a [glob_constr] into a notation given the list of variables bound by the notation; also interpret recursive patterns *) @@ -40,7 +40,7 @@ val glob_constr_of_notation_constr_with_binders : Loc.t -> val glob_constr_of_notation_constr : Loc.t -> notation_constr -> glob_constr -(** {5 Matching a notation pattern against a [glob_constr] *) +(** {5 Matching a notation pattern against a [glob_constr]} *) (** [match_notation_constr] matches a [glob_constr] against a notation interpretation; raise [No_match] if the matching fails *) @@ -64,5 +64,5 @@ val match_notation_constr_ind_pattern : ((cases_pattern * subscopes) list * (cases_pattern list * subscopes) list) * (int * cases_pattern list) -(** {5 Matching a notation pattern against a [glob_constr] *) +(** {5 Matching a notation pattern against a [glob_constr]} *) |